Session Polynomials

Theory Utils

(* Author: Alexander Maletzky *)

section ‹Utilities›

theory Utils
  imports Main Well_Quasi_Orders.Almost_Full_Relations
begin

lemma subset_imageE_inj:
  assumes "B  f ` A"
  obtains C where "C  A" and "B = f ` C" and "inj_on f C"
proof -
  define g where "g = (λx. SOME a. a  A  f a = x)"
  have "g b  A  f (g b) = b" if "b  B" for b
  proof -
    from that assms have "b  f ` A" ..
    then obtain a where "a  A" and "b = f a" ..
    hence "a  A  f a = b" by simp
    thus ?thesis unfolding g_def by (rule someI)
  qed
  hence 1: "b. b  B  g b  A" and 2: "b. b  B  f (g b) = b" by simp_all
  let ?C = "g ` B"
  show ?thesis
  proof
    show "?C  A" by (auto intro: 1)
  next
    show "B = f ` ?C"
    proof (rule set_eqI)
      fix b
      show "b  B  b  f ` ?C"
      proof
        assume "b  B"
        moreover from this have "f (g b) = b" by (rule 2)
        ultimately show "b  f ` ?C" by force
      next
        assume "b  f ` ?C"
        then obtain b' where "b'  B" and "b = f (g b')" unfolding image_image ..
        moreover from this(1) have "f (g b') = b'" by (rule 2)
        ultimately show "b  B" by simp
      qed
    qed
  next
    show "inj_on f ?C"
    proof
      fix x y
      assume "x  ?C"
      then obtain bx where "bx  B" and x: "x = g bx" ..
      moreover from this(1) have "f (g bx) = bx" by (rule 2)
      ultimately have *: "f x = bx" by simp
      assume "y  ?C"
      then obtain "by" where "by  B" and y: "y = g by" ..
      moreover from this(1) have "f (g by) = by" by (rule 2)
      ultimately have "f y = by" by simp
      moreover assume "f x = f y"
      ultimately have "bx = by" using * by simp
      thus "x = y" by (simp only: x y)
    qed
  qed
qed

lemma wfP_chain:
  assumes "¬(f. i. r (f (Suc i)) (f i))"
  shows "wfP r"
proof -
  from assms wf_iff_no_infinite_down_chain[of "{(x, y). r x y}"] have "wf {(x, y). r x y}" by auto
  thus "wfP r" unfolding wfP_def .
qed

lemma transp_sequence:
  assumes "transp r" and "i. r (seq (Suc i)) (seq i)" and "i < j"
  shows "r (seq j) (seq i)"
proof -
  have "k. r (seq (i + Suc k)) (seq i)"
  proof -
    fix k::nat
    show "r (seq (i + Suc k)) (seq i)"
    proof (induct k)
      case 0
      from assms(2) have "r (seq (Suc i)) (seq i)" .
      thus ?case by simp
    next
      case (Suc k)
      note assms(1)
      moreover from assms(2) have "r (seq (Suc (Suc i + k))) (seq (Suc (i + k)))" by simp
      moreover have "r (seq (Suc (i + k))) (seq i)" using Suc.hyps by simp
      ultimately have "r (seq (Suc (Suc i + k))) (seq i)" by (rule transpD)
      thus ?case by simp
    qed
  qed
  hence "r (seq (i + Suc(j - i - 1))) (seq i)" .
  thus "r (seq j) (seq i)" using i < j by simp
qed

lemma almost_full_on_finite_subsetE:
  assumes "reflp P" and "almost_full_on P S"
  obtains T where "finite T" and "T  S" and "s. s  S  (tT. P t s)"
proof -
  define crit where "crit = (λU s. s  S  (uU. ¬ P u s))"
  have critD: "s  U" if "crit U s" for U s
  proof
    assume "s  U"
    from crit U s have "uU. ¬ P u s" unfolding crit_def ..
    from this s  U have "¬ P s s" ..
    moreover from assms(1) have "P s s" by (rule reflpD)
    ultimately show False ..
  qed
  define "fun"
    where "fun = (λU. (if (s. crit U s) then
                        insert (SOME s. crit U s) U
                      else
                        U
                      ))"
  define seq where "seq = rec_nat {} (λ_. fun)"
  have seq_Suc: "seq (Suc i) = fun (seq i)" for i by (simp add: seq_def)
  
  have seq_incr_Suc: "seq i  seq (Suc i)" for i by (auto simp add: seq_Suc fun_def)
  have seq_incr: "i  j  seq i  seq j" for i j
  proof -
    assume "i  j"
    hence "i = j  i < j" by auto
    thus "seq i  seq j"
    proof
      assume "i = j"
      thus ?thesis by simp
    next
      assume "i < j"
      with _ seq_incr_Suc show ?thesis by (rule transp_sequence, simp add: transp_def)
    qed
  qed
  have sub: "seq i  S" for i
  proof (induct i, simp add: seq_def, simp add: seq_Suc fun_def, rule)
    fix i
    assume "Ex (crit (seq i))"
    hence "crit (seq i) (Eps (crit (seq i)))" by (rule someI_ex)
    thus "Eps (crit (seq i))  S" by (simp add: crit_def)
  qed
  have "i. seq (Suc i) = seq i"
  proof (rule ccontr, simp)
    assume "i. seq (Suc i)  seq i"
    with seq_incr_Suc have "seq i  seq (Suc i)" for i by blast
    define seq1 where "seq1 = (λn. (SOME s. s  seq (Suc n)  s  seq n))"
    have seq1: "seq1 n  seq (Suc n)  seq1 n  seq n" for n unfolding seq1_def
    proof (rule someI_ex)
      from seq n  seq (Suc n) show "x. x  seq (Suc n)  x  seq n" by blast
    qed
    have "seq1 i  S" for i
    proof
      from seq1[of i] show "seq1 i  seq (Suc i)" ..
    qed (fact sub)
    with assms(2) obtain a b where "a < b" and "P (seq1 a) (seq1 b)" by (rule almost_full_onD)
    from a < b have "Suc a  b" by simp
    from seq1 have "seq1 a  seq (Suc a)" ..
    also from ‹Suc a  b have "...  seq b" by (rule seq_incr)
    finally have "seq1 a  seq b" .
    from seq1 have "seq1 b  seq (Suc b)" and "seq1 b  seq b" by blast+
    hence "crit (seq b) (seq1 b)" by (simp add: seq_Suc fun_def someI split: if_splits)
    hence "useq b. ¬ P u (seq1 b)" by (simp add: crit_def)
    from this seq1 a  seq b have "¬ P (seq1 a) (seq1 b)" ..
    from this P (seq1 a) (seq1 b) show False ..
  qed
  then obtain i where "seq (Suc i) = seq i" ..
  show ?thesis
  proof
    show "finite (seq i)" by (induct i, simp_all add: seq_def fun_def)
  next
    fix s
    assume "s  S"
    let ?s = "Eps (crit (seq i))"
    show "tseq i. P t s"
    proof (rule ccontr, simp)
      assume "tseq i. ¬ P t s"
      with s  S have "crit (seq i) s" by (simp only: crit_def)
      hence "crit (seq i) ?s" and eq: "seq (Suc i) = insert ?s (seq i)"
        by (auto simp add: seq_Suc fun_def intro: someI)
      from this(1) have "?s  seq i" by (rule critD)
      hence "seq (Suc i)  seq i" unfolding eq by blast
      from this seq (Suc i) = seq i show False ..
    qed
  qed (fact sub)
qed

subsection ‹Lists›

lemma map_upt: "map (λi. f (xs ! i)) [0..<length xs] = map f xs"
  by (auto intro: nth_equalityI)

lemma map_upt_zip:
  assumes "length xs = length ys"
  shows "map (λi. f (xs ! i) (ys ! i)) [0..<length ys] = map (λ(x, y). f x y) (zip xs ys)" (is "?l = ?r")
proof -
  have len_l: "length ?l = length ys" by simp
  from assms have len_r: "length ?r = length ys" by simp
  show ?thesis
  proof (simp only: list_eq_iff_nth_eq len_l len_r, rule, rule, intro allI impI)
    fix i
    assume "i < length ys"
    hence "i < length ?l" and "i < length ?r" by (simp_all only: len_l len_r)
    thus "map (λi. f (xs ! i) (ys ! i)) [0..<length ys] ! i = map (λ(x, y). f x y) (zip xs ys) ! i"
      by simp
  qed
qed

lemma distinct_sorted_wrt_irrefl:
  assumes "irreflp rel" and "transp rel" and "sorted_wrt rel xs"
  shows "distinct xs"
  using assms(3)
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  from Cons(2) have "sorted_wrt rel xs" and *: "yset xs. rel x y"
    by (simp_all)
  from this(1) have "distinct xs" by (rule Cons(1))
  show ?case
  proof (simp add: ‹distinct xs, rule)
    assume "x  set xs"
    with * have "rel x x" ..
    with assms(1) show False by (simp add: irreflp_def)
  qed
qed

lemma distinct_sorted_wrt_imp_sorted_wrt_strict:
  assumes "distinct xs" and "sorted_wrt rel xs"
  shows "sorted_wrt (λx y. rel x y  ¬ x = y) xs"
  using assms
proof (induct xs)
  case Nil
  show ?case by simp
next
  case step: (Cons x xs)
  show ?case
  proof (cases "xs")
    case Nil
    thus ?thesis by simp
  next
    case (Cons y zs)
    from step(2) have "x  y" and 1: "distinct (y # zs)" by (simp_all add: Cons)
    from step(3) have "rel x y" and 2: "sorted_wrt rel (y # zs)" by (simp_all add: Cons)
    from 1 2 have "sorted_wrt (λx y. rel x y  x  y) (y # zs)" by (rule step(1)[simplified Cons])
    with x  y rel x y show ?thesis using step.prems by (auto simp: Cons)
  qed
qed

lemma sorted_wrt_distinct_set_unique:
  assumes "antisymp rel"
  assumes "sorted_wrt rel xs" "distinct xs" "sorted_wrt rel ys" "distinct ys" "set xs = set ys"
  shows "xs = ys"
proof -
  from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  from assms(2-6) show ?thesis
  proof(induct rule:list_induct2[OF 1])
    case 1
    show ?case by simp
  next
    case (2 x xs y ys)
    from 2(4) have "x  set xs" and "distinct xs" by simp_all
    from 2(6) have "y  set ys" and "distinct ys" by simp_all
    have "x = y"
    proof (rule ccontr)
      assume "x  y"
      from 2(3) have "zset xs. rel x z" by (simp)
      moreover from x  y have "y  set xs" using 2(7) by auto
      ultimately have *: "rel x y" ..
      from 2(5) have "zset ys. rel y z" by (simp)
      moreover from x  y have "x  set ys" using 2(7) by auto
      ultimately have "rel y x" ..
      with assms(1) * have "x = y" by (rule antisympD)
      with x  y show False ..
    qed
    from 2(3) have "sorted_wrt rel xs" by (simp)
    moreover note ‹distinct xs
    moreover from 2(5) have "sorted_wrt rel ys" by (simp)
    moreover note ‹distinct ys
    moreover from 2(7) x  set xs y  set ys have "set xs = set ys" by (auto simp add: x = y)
    ultimately have "xs = ys" by (rule 2(2))
    with x = y show ?case by simp
  qed
qed

lemma sorted_wrt_refl_nth_mono:
  assumes "reflp P" and "sorted_wrt P xs" and "i  j" and "j < length xs"
  shows "P (xs ! i) (xs ! j)"
proof (cases "i < j")
  case True
  from assms(2) this assms(4) show ?thesis by (rule sorted_wrt_nth_less)
next
  case False
  with assms(3) have "i = j" by simp
  from assms(1) show ?thesis unfolding i = j by (rule reflpD)
qed

fun merge_wrt :: "('a  'a  bool)  'a list  'a list  'a list" where
  "merge_wrt _ xs [] = xs"|
  "merge_wrt rel [] ys = ys"|
  "merge_wrt rel (x # xs) (y # ys) =
    (if x = y then
      y # (merge_wrt rel xs ys)
    else if rel x y then
      x # (merge_wrt rel xs (y # ys))
    else
      y # (merge_wrt rel (x # xs) ys)
    )"

lemma set_merge_wrt: "set (merge_wrt rel xs ys) = set xs  set ys"
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  show ?case by simp
next
  case (2 rel y ys)
  show ?case by simp
next
  case (3 rel x xs y ys)
  show ?case
  proof (cases "x = y")
    case True
    thus ?thesis by (simp add: 3(1))
  next
    case False
    show ?thesis
    proof (cases "rel x y")
      case True
      with x  y show ?thesis by (simp add: 3(2) insert_commute)
    next
      case False
      with x  y show ?thesis by (simp add: 3(3))
    qed
  qed
qed

lemma sorted_merge_wrt:
  assumes "transp rel" and "x y. x  y  rel x y  rel y x"
    and "sorted_wrt rel xs" and "sorted_wrt rel ys"
  shows "sorted_wrt rel (merge_wrt rel xs ys)"
  using assms
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  from 1(3) show ?case by simp
next
  case (2 rel y ys)
  from 2(4) show ?case by simp
next
  case (3 rel x xs y ys)
  show ?case
  proof (cases "x = y")
    case True
    show ?thesis
    proof (auto simp add: True)
      fix z
      assume "z  set (merge_wrt rel xs ys)"
      hence "z  set xs  set ys" by (simp only: set_merge_wrt)
      thus "rel y z"
      proof
        assume "z  set xs"
        with 3(6) show ?thesis by (simp add: True)
      next
        assume "z  set ys"
        with 3(7) show ?thesis by (simp)
      qed
    next
      note True 3(4, 5)
      moreover from 3(6) have "sorted_wrt rel xs" by (simp)
      moreover from 3(7) have "sorted_wrt rel ys" by (simp)
      ultimately show "sorted_wrt rel (merge_wrt rel xs ys)" by (rule 3(1))
    qed
  next
    case False
    show ?thesis
    proof (cases "rel x y")
      case True
      show ?thesis
      proof (auto simp add: False True)
        fix z
        assume "z  set (merge_wrt rel xs (y # ys))"
        hence "z  insert y (set xs  set ys)" by (simp add: set_merge_wrt)
        thus "rel x z"
        proof
          assume "z = y"
          with True show ?thesis by simp
        next
          assume "z  set xs  set ys"
          thus ?thesis
          proof
            assume "z  set xs"
            with 3(6) show ?thesis by (simp)
          next
            assume "z  set ys"
            with 3(7) have "rel y z" by (simp)
            with 3(4) True show ?thesis by (rule transpD)
          qed
        qed
      next
        note False True 3(4, 5)
        moreover from 3(6) have "sorted_wrt rel xs" by (simp)
        ultimately show "sorted_wrt rel (merge_wrt rel xs (y # ys))" using 3(7) by (rule 3(2))
      qed
    next
      assume "¬ rel x y"
      from x  y have "rel x y  rel y x" by (rule 3(5))
      with ¬ rel x y have *: "rel y x" by simp
      show ?thesis
      proof (auto simp add: False ¬ rel x y)
        fix z
        assume "z  set (merge_wrt rel (x # xs) ys)"
        hence "z  insert x (set xs  set ys)" by (simp add: set_merge_wrt)
        thus "rel y z"
        proof
          assume "z = x"
          with * show ?thesis by simp
        next
          assume "z  set xs  set ys"
          thus ?thesis
          proof
            assume "z  set xs"
            with 3(6) have "rel x z" by (simp)
            with 3(4) * show ?thesis by (rule transpD)
          next
            assume "z  set ys"
            with 3(7) show ?thesis by (simp)
          qed
        qed
      next
        note False ¬ rel x y 3(4, 5, 6)
        moreover from 3(7) have "sorted_wrt rel ys" by (simp)
        ultimately show "sorted_wrt rel (merge_wrt rel (x # xs) ys)" by (rule 3(3))
      qed
    qed
  qed
qed

lemma set_fold:
  assumes "x ys. set (f (g x) ys) = set (g x)  set ys"
  shows "set (fold (λx. f (g x)) xs ys) = (xset xs. set (g x))  set ys"
proof (induct xs arbitrary: ys)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have eq: "set (fold (λx. f (g x)) xs (f (g x) ys)) = (xset xs. set (g x))  set (f (g x) ys)"
    by (rule Cons)
  show ?case by (simp add: o_def assms set_merge_wrt eq ac_simps)
qed

subsection ‹Sums and Products›

lemma additive_implies_homogenous:
  assumes "x y. f (x + y) = f x + ((f (y::'a::monoid_add))::'b::cancel_comm_monoid_add)"
  shows "f 0 = 0"
proof -
  have "f (0 + 0) = f 0 + f 0" by (rule assms)
  hence "f 0 = f 0 + f 0" by simp
  thus "f 0 = 0" by simp
qed

lemma fun_sum_commute:
  assumes "f 0 = 0" and "x y. f (x + y) = f x + f y"
  shows "f (sum g A) = (aA. f (g a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    thus ?case by (simp add: assms(1))
  next
    case step: (insert a A)
    show ?case by (simp add: sum.insert[OF step(1) step(2)] assms(2) step(3))
  qed
next
  case False
  thus ?thesis by (simp add: assms(1))
qed

lemma fun_sum_commute_canc:
  assumes "x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
  shows "f (sum g A) = (aA. f (g a))"
  by (rule fun_sum_commute, rule additive_implies_homogenous, fact+)

lemma fun_sum_list_commute:
  assumes "f 0 = 0" and "x y. f (x + y) = f x + f y"
  shows "f (sum_list xs) = sum_list (map f xs)"
proof (induct xs)
  case Nil
  thus ?case by (simp add: assms(1))
next
  case (Cons x xs)
  thus ?case by (simp add: assms(2))
qed

lemma fun_sum_list_commute_canc:
  assumes "x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
  shows "f (sum_list xs) = sum_list (map f xs)"
  by (rule fun_sum_list_commute, rule additive_implies_homogenous, fact+)

lemma sum_set_upt_eq_sum_list: "(i = m..<n. f i) = (i[m..<n]. f i)"
  using sum_set_upt_conv_sum_list_nat by auto

lemma sum_list_upt: "(i[0..<(length xs)]. f (xs ! i)) = (xxs. f x)"
  by (simp only: map_upt)

lemma sum_list_upt_zip:
  assumes "length xs = length ys"
  shows "(i[0..<(length ys)]. f (xs ! i) (ys ! i)) = ((x, y)(zip xs ys). f x y)"
  by (simp only: map_upt_zip[OF assms])

lemma sum_list_zeroI:
  assumes "set xs  {0}"
  shows "sum_list xs = 0"
  using assms by (induct xs, auto)

lemma fun_prod_commute:
  assumes "f 1 = 1" and "x y. f (x * y) = f x * f y"
  shows "f (prod g A) = (aA. f (g a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    thus ?case by (simp add: assms(1))
  next
    case step: (insert a A)
    show ?case by (simp add: prod.insert[OF step(1) step(2)] assms(2) step(3))
  qed
next
  case False
  thus ?thesis by (simp add: assms(1))
qed

end (* theory *)

Theory MPoly_Type

(* Author: Andreas Lochbihler, ETH Zurich
   Author: Florian Haftmann, TU Muenchen
*)

section ‹An abstract type for multivariate polynomials›

theory MPoly_Type
imports "HOL-Library.Poly_Mapping"
begin

subsection ‹Abstract type definition›

typedef (overloaded) 'a mpoly =
  "UNIV :: ((nat 0 nat) 0 'a::zero) set"
  morphisms mapping_of MPoly
 ..

setup_lifting type_definition_mpoly

(* these theorems are automatically generated by setup_lifting... *)
thm mapping_of_inverse   thm MPoly_inverse
thm mapping_of_inject    thm MPoly_inject
thm mapping_of_induct    thm MPoly_induct
thm mapping_of_cases     thm MPoly_cases


subsection ‹Additive structure›

instantiation mpoly :: (zero) zero
begin

lift_definition zero_mpoly :: "'a mpoly"
  is "0 :: (nat 0 nat) 0 'a" .

instance ..

end

instantiation mpoly :: (monoid_add) monoid_add
begin

lift_definition plus_mpoly :: "'a mpoly  'a mpoly  'a mpoly"
  is "Groups.plus :: ((nat 0 nat) 0 'a)  _" .

instance
  by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+

end

instance mpoly :: (comm_monoid_add) comm_monoid_add
  by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+

instantiation mpoly :: (cancel_comm_monoid_add) cancel_comm_monoid_add
begin

lift_definition minus_mpoly :: "'a mpoly  'a mpoly  'a mpoly"
  is "Groups.minus :: ((nat 0 nat) 0 'a)  _" .

instance
  by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+

end

instantiation mpoly :: (ab_group_add) ab_group_add
begin

lift_definition uminus_mpoly :: "'a mpoly  'a mpoly"
  is "Groups.uminus :: ((nat 0 nat) 0 'a)  _" .


instance
  by intro_classes (transfer, simp add: fun_eq_iff add_uminus_conv_diff)+

end


subsection ‹Multiplication by a coefficient›
(* ?do we need inc_power on abstract polynomials? *)

lift_definition smult :: "'a::{times,zero}  'a mpoly  'a mpoly"
  is "λa. Poly_Mapping.map (Groups.times a) :: ((nat 0 nat) 0 'a)  _" .

(* left lemmas in subsection ‹Pseudo-division of polynomials›,
   because I couldn't disentangle them and the notion of monomials. *)

subsection ‹Multiplicative structure›

instantiation mpoly :: (zero_neq_one) zero_neq_one
begin

lift_definition one_mpoly :: "'a mpoly"
  is "1 :: ((nat 0 nat) 0 'a)" .

instance
  by intro_classes (transfer, simp)

end

instantiation mpoly :: (semiring_0) semiring_0
begin

lift_definition times_mpoly :: "'a mpoly  'a mpoly  'a mpoly"
  is "Groups.times :: ((nat 0 nat) 0 'a)  _" .

instance
  by intro_classes (transfer, simp add: algebra_simps)+

end

instance mpoly :: (comm_semiring_0) comm_semiring_0
  by intro_classes (transfer, simp add: algebra_simps)+

instance mpoly :: (semiring_0_cancel) semiring_0_cancel
  ..

instance mpoly :: (comm_semiring_0_cancel) comm_semiring_0_cancel
  ..

instance mpoly :: (semiring_1) semiring_1
  by intro_classes (transfer, simp)+

instance mpoly :: (comm_semiring_1) comm_semiring_1
  by intro_classes (transfer, simp)+

instance mpoly :: (semiring_1_cancel) semiring_1_cancel
  ..

(*instance mpoly :: (comm_semiring_1_cancel) comm_semiring_1_cancel
  .. FIXME unclear whether this holds *)

instance mpoly :: (ring) ring
  ..

instance mpoly :: (comm_ring) comm_ring
  ..

instance mpoly :: (ring_1) ring_1
  ..

instance mpoly :: (comm_ring_1) comm_ring_1
  ..


subsection ‹Monomials›

text ‹
  Terminology is not unique here, so we use the notions as follows:
  A "monomial" and a "coefficient" together give a "term".
  These notions are significant in connection with "leading",
  "leading term", "leading coefficient" and "leading monomial",
  which all rely on a monomial order.
›

lift_definition monom :: "(nat 0 nat)  'a::zero  'a mpoly"
  is "Poly_Mapping.single :: (nat 0 nat)  _" .

lemma mapping_of_monom [simp]:
  "mapping_of (monom m a) = Poly_Mapping.single m a"
  by(fact monom.rep_eq)

lemma monom_zero [simp]:
  "monom 0 0 = 0"
  by transfer simp

lemma monom_one [simp]:
  "monom 0 1 = 1"
  by transfer simp

lemma monom_add:
  "monom m (a + b) = monom m a + monom m b"
  by transfer (simp add: single_add)

lemma monom_uminus:
  "monom m (- a) = - monom m a"
  by transfer (simp add: single_uminus)

lemma monom_diff:
  "monom m (a - b) = monom m a - monom m b"
  by transfer (simp add: single_diff)

lemma monom_numeral [simp]:
  "monom 0 (numeral n) = numeral n"
  by (induct n) (simp_all only: numeral.simps numeral_add monom_zero monom_one monom_add)

lemma monom_of_nat [simp]:
  "monom 0 (of_nat n) = of_nat n"
  by (induct n) (simp_all add: monom_add)

lemma of_nat_monom:
  "of_nat = monom 0  of_nat"
  by (simp add: fun_eq_iff)

lemma inj_monom [iff]:
  "inj (monom m)"
proof (rule injI, transfer)
  fix a b :: 'a and m :: "nat 0 nat"
  assume "Poly_Mapping.single m a = Poly_Mapping.single m b"
  with injD [of "Poly_Mapping.single m" a b]
  show "a = b" by simp
qed

lemma mult_monom: "monom x a * monom y b = monom (x + y) (a * b)"
  by transfer' (simp add: Poly_Mapping.mult_single)

instance mpoly :: (semiring_char_0) semiring_char_0
  by intro_classes (auto simp add: of_nat_monom inj_of_nat intro: inj_compose)

instance mpoly :: (ring_char_0) ring_char_0
  ..

lemma monom_of_int [simp]:
  "monom 0 (of_int k) = of_int k"
  apply (cases k)
  apply simp_all
  unfolding monom_diff monom_uminus
  apply simp
  done

subsection ‹Constants and Indeterminates›

text ‹Embedding of indeterminates and constants in type-class polynomials,
  can be used as constructors.›

definition Var0 :: "'a  ('a 0 nat) 0 'b::{one,zero}" where
  "Var0 n  Poly_Mapping.single (Poly_Mapping.single n 1) 1"
definition Const0 :: "'b  ('a 0 nat) 0 'b::zero" where "Const0 c  Poly_Mapping.single 0 c"

lemma Const0_one: "Const0 1 = 1"
  by (simp add: Const0_def)

lemma Const0_numeral: "Const0 (numeral x) = numeral x"
  by (auto intro!: poly_mapping_eqI simp: Const0_def lookup_numeral)

lemma Const0_minus: "Const0 (- x) = - Const0 x"
  by (simp add: Const0_def single_uminus)

lemma Const0_zero: "Const0 0 = 0"
  by (auto intro!: poly_mapping_eqI simp: Const0_def)

lemma Var0_power: "Var0 v ^ n = Poly_Mapping.single (Poly_Mapping.single v n) 1"
  by (induction n) (auto simp: Var0_def mult_single single_add[symmetric])

lift_definition Var::"nat  'b::{one,zero} mpoly" is Var0 .
lift_definition Const::"'b::zero  'b mpoly" is Const0 .


subsection ‹Integral domains›

instance mpoly :: (ring_no_zero_divisors) ring_no_zero_divisors
  by intro_classes (transfer, simp)

instance mpoly :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors
  ..

instance mpoly :: (idom) idom
  ..


subsection ‹Monom coefficient lookup›

definition coeff :: "'a::zero mpoly  (nat 0 nat)  'a"
where
  "coeff p = Poly_Mapping.lookup (mapping_of p)"


subsection ‹Insertion morphism›

definition insertion_fun_natural :: "(nat  'a)  ((nat  nat)  'a)  'a::comm_semiring_1"
where
  "insertion_fun_natural f p = (m. p m * (v. f v ^ m v))"

definition insertion_fun :: "(nat  'a)  ((nat 0 nat)  'a)  'a::comm_semiring_1"
where
  "insertion_fun f p = (m. p m * (v. f v ^ Poly_Mapping.lookup m v))"

text ‹N.b. have been unable to relate this to @{const insertion_fun_natural} using lifting!›

lift_definition insertion_aux :: "(nat  'a)  ((nat 0 nat) 0 'a)  'a::comm_semiring_1"
  is "insertion_fun" .

lift_definition insertion :: "(nat  'a)  'a mpoly  'a::comm_semiring_1"
  is "insertion_aux" .

lemma aux:
  "Poly_Mapping.lookup f = (λ_. 0)  f = 0"
  apply transfer apply simp done

lemma insertion_trivial [simp]:
  "insertion (λ_. 0) p = coeff p 0"
proof -
  { fix f :: "(nat 0 nat) 0 'a"
    have "insertion_aux (λ_. 0) f = Poly_Mapping.lookup f 0"
      apply (simp add: insertion_aux_def insertion_fun_def power_Sum_any [symmetric])
      apply (simp add: zero_power_eq mult_when aux)
      done
  }
  then show ?thesis by (simp add: coeff_def insertion_def)
qed

lemma insertion_zero [simp]:
  "insertion f 0 = 0"
  by transfer (simp add: insertion_aux_def insertion_fun_def)

lemma insertion_fun_add:
  fixes f p q
  shows "insertion_fun f (Poly_Mapping.lookup (p + q)) =
    insertion_fun f (Poly_Mapping.lookup p) +
      insertion_fun f (Poly_Mapping.lookup q)"
  unfolding insertion_fun_def
  apply (subst Sum_any.distrib [symmetric])
  apply (simp_all add: plus_poly_mapping.rep_eq algebra_simps)
  apply (rule finite_mult_not_eq_zero_rightI)
  apply simp
  apply (rule finite_mult_not_eq_zero_rightI)
  apply simp
  done

lemma insertion_add:
  "insertion f (p + q) = insertion f p + insertion f q"
  by transfer (simp add: insertion_aux_def insertion_fun_add)

lemma insertion_one [simp]:
  "insertion f 1 = 1"
  by transfer (simp add: insertion_aux_def insertion_fun_def one_poly_mapping.rep_eq when_mult)

lemma insertion_fun_mult:
  fixes f p q
  shows "insertion_fun f (Poly_Mapping.lookup (p * q)) =
    insertion_fun f (Poly_Mapping.lookup p) *
      insertion_fun f (Poly_Mapping.lookup q)"
proof -
  { fix m :: "nat 0 nat"
    have "finite {v. Poly_Mapping.lookup m v  0}"
      by simp
    then have "finite {v. f v ^ Poly_Mapping.lookup m v  1}"
      by (rule rev_finite_subset) (auto intro: ccontr)
  }
  moreover define g where "g m = (v. f v ^ Poly_Mapping.lookup m v)" for m
  ultimately have *: "a b. g (a + b) = g a * g b"
    by (simp add: plus_poly_mapping.rep_eq power_add Prod_any.distrib)
  have bij: "bij (λ(l, n, m). (m, l, n))"
    by (auto intro!: bijI injI simp add: image_def)
  let ?P = "{l. Poly_Mapping.lookup p l  0}"
  let ?Q = "{n. Poly_Mapping.lookup q n  0}"
  let ?PQ = "{l + n | l n. l  Poly_Mapping.keys p  n  Poly_Mapping.keys q}"
  have "finite {l + n | l n. Poly_Mapping.lookup p l  0  Poly_Mapping.lookup q n  0}"
    by (rule finite_not_eq_zero_sumI) simp_all
  then have fin_PQ: "finite ?PQ"
    by (simp add: in_keys_iff)
  have "(m. Poly_Mapping.lookup (p * q) m * g m) =
    (m. (l. Poly_Mapping.lookup p l * (n. Poly_Mapping.lookup q n when m = l + n)) * g m)"
    by (simp add: times_poly_mapping.rep_eq prod_fun_def)
  also have " = (m. (l. (n. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)))"
    apply (subst Sum_any_left_distrib)
    apply (auto intro: finite_mult_not_eq_zero_rightI)
    apply (subst Sum_any_right_distrib)
    apply (auto intro: finite_mult_not_eq_zero_rightI)
    apply (subst Sum_any_left_distrib)
    apply (auto intro: finite_mult_not_eq_zero_leftI)
    apply (simp add: ac_simps mult_when)
    done
  also have " = (m. ((l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n))"
    apply (subst (2) Sum_any.cartesian_product [of "?P × ?Q"])
    apply (auto dest!: mult_not_zero)
    done
  also have " = ((m, l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    apply (subst Sum_any.cartesian_product [of "?PQ × (?P × ?Q)"])
      apply (auto dest!: mult_not_zero simp add: fin_PQ)
    apply (auto simp: in_keys_iff)
    done
  also have " = ((l, n, m). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    using bij by (rule Sum_any.reindex_cong [of "λ(l, n, m). (m, l, n)"]) (simp add: fun_eq_iff)
  also have " = ((l, n). m. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    apply (subst Sum_any.cartesian_product2 [of "(?P × ?Q) × ?PQ"])
    apply (auto dest!: mult_not_zero simp add: fin_PQ )
    apply (auto simp: in_keys_iff)
    done
  also have " = ((l, n). (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
    by (simp add: *)
  also have " = (l. n. (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
    apply (subst Sum_any.cartesian_product [of "?P × ?Q"])
    apply (auto dest!: mult_not_zero)
    done
  also have " = (l. n. (Poly_Mapping.lookup p l * g l) * (Poly_Mapping.lookup q n * g n))"
    by (simp add: ac_simps)
  also have " =
    (m. Poly_Mapping.lookup p m * g m) *
    (m. Poly_Mapping.lookup q m * g m)"
    by (rule Sum_any_product [symmetric]) (auto intro: finite_mult_not_eq_zero_rightI)
  finally show ?thesis by (simp add: insertion_fun_def g_def)
qed

lemma insertion_mult:
  "insertion f (p * q) = insertion f p * insertion f q"
  by transfer (simp add: insertion_aux_def insertion_fun_mult)


subsection ‹Degree›

lift_definition degree :: "'a::zero mpoly  nat  nat"
is "λp v. Max (insert 0 ((λm. Poly_Mapping.lookup m v) ` Poly_Mapping.keys p))" .


lift_definition total_degree :: "'a::zero mpoly  nat"
is "λp. Max (insert 0 ((λm. sum (Poly_Mapping.lookup m) (Poly_Mapping.keys m)) ` Poly_Mapping.keys p))" .

lemma degree_zero [simp]:
  "degree 0 v = 0"
  by transfer simp

lemma total_degree_zero [simp]:
  "total_degree 0 = 0"
  by transfer simp
(*
value [code] "total_degree (0 :: int mpoly)" (***)
*)

lemma degree_one [simp]:
  "degree 1 v = 0"
  by transfer simp

lemma total_degree_one [simp]:
  "total_degree 1 = 0"
  by transfer simp

subsection ‹Pseudo-division of polynomials›

lemma smult_conv_mult: "smult s p = monom 0 s * p"
by transfer (simp add: mult_map_scale_conv_mult)

lemma smult_monom [simp]:
  fixes c :: "_ :: mult_zero"
  shows "smult c (monom x c') = monom x (c * c')"
by transfer simp

lemma smult_0 [simp]:
  fixes p :: "_ :: mult_zero mpoly"
  shows "smult 0 p = 0"
by transfer(simp add: map_eq_zero_iff)

lemma mult_smult_left: "smult s p * q = smult s (p * q)"
by(simp add: smult_conv_mult mult.assoc)

lift_definition sdiv :: "'a::euclidean_ring  'a mpoly  'a mpoly"
  is "λa. Poly_Mapping.map (λb. b div a) :: ((nat 0 nat) 0 'a)  _"
.
text ‹
  \qt{Polynomial division} is only possible on univariate polynomials K[x]›
  over a field K›, all other kinds of polynomials only allow pseudo-division
  [1]p.40/41":

  ∀x y :: 'a mpoly. y ≠ 0 ⇒ ∃a q r. smult a x = q * y + r›

  The introduction of pseudo-division below generalises @{file ‹~~/src/HOL/Computational_Algebra/Polynomial.thy›}.
  [1] Winkler, Polynomial Algorithms, 1996.
  The generalisation raises issues addressed by Wenda Li and commented below.
  Florian replied to the issues conjecturing, that the abstract mpoly needs not
  be aware of the issues, in case these are only concerned with executability.
›

definition pseudo_divmod_rel
  :: "'a::euclidean_ring => 'a mpoly => 'a mpoly => 'a mpoly => 'a mpoly => bool"
where
  "pseudo_divmod_rel a x y q r 
    smult a x = q * y + r  (if y = 0 then q = 0 else r = 0  degree r < degree y)"
(* the notion of degree resigns a main variable in multivariate polynomials;
   also, there are infinitely many tuples (a,q,r) such that a x = q y + r *)

definition pdiv :: "'a::euclidean_ring mpoly  'a mpoly  ('a × 'a mpoly)" (infixl "pdiv" 70)
where
  "x pdiv y = (THE (a, q). r. pseudo_divmod_rel a x y q r)"

definition pmod :: "'a::euclidean_ring mpoly  'a mpoly  'a mpoly" (infixl "pmod" 70)
where
  "x pmod y = (THE r. a q. pseudo_divmod_rel a x y q r)"

definition pdivmod :: "'a::euclidean_ring mpoly  'a mpoly  ('a × 'a mpoly) × 'a mpoly"
where
  "pdivmod p q = (p pdiv q, p pmod q)"

(* "_code" seems inappropriate, since "THE" in definitions pdiv and pmod is not unique,
   see comment to definition pseudo_divmod_rel; so this cannot be executable ... *)
lemma pdiv_code:
  "p pdiv q = fst (pdivmod p q)"
  by (simp add: pdivmod_def)

lemma pmod_code:
  "p pmod q = snd (pdivmod p q)"
  by (simp add: pdivmod_def)

(*TODO ERROR: Ambiguous input produces n parse trees ???...*)
definition div :: "'a::{euclidean_ring,field} mpoly  'a mpoly  'a mpoly" (infixl "div" 70)
where
  "x div y = (THE q'. a q r. (pseudo_divmod_rel a x y q r)  (q' = smult (inverse a) q))"

definition mod :: "'a::{euclidean_ring,field} mpoly  'a mpoly  'a mpoly" (infixl "mod" 70)
where
  "x mod y = (THE r'. a q r. (pseudo_divmod_rel a x y q r)  (r' = smult (inverse a) r))"

definition divmod :: "'a::{euclidean_ring,field} mpoly  'a mpoly  'a mpoly × 'a mpoly"
where
  "divmod p q = (p div q, p mod q)"

lemma div_poly_code:
  "p div q = fst (divmod p q)"
  by (simp add: divmod_def)

lemma mod_poly_code:
  "p mod q = snd (divmod p q)"
  by (simp add: divmod_def)

subsection ‹Primitive poly, etc›

lift_definition coeffs :: "'a :: zero mpoly  'a set"
is "Poly_Mapping.range :: ((nat 0 nat) 0 'a)  _" .

lemma finite_coeffs [simp]: "finite (coeffs p)"
by transfer simp

text ‹[1]p.82
  A "primitive'" polynomial has coefficients with GCD equal to 1.
  A polynomial is factored into "content" and "primitive part"
  for many different purposes.›

definition primitive :: "'a::{euclidean_ring,semiring_Gcd} mpoly  bool"
where
  "primitive p  Gcd (coeffs p) = 1"

definition content_primitive :: "'a::{euclidean_ring,GCD.Gcd} mpoly  'a × 'a mpoly"
where
  "content_primitive p = (
    let d = Gcd (coeffs p)
    in (d, sdiv d p))"

value "let p = M [1,2,3] (4::int) + M [2,0,4] 6 + M [2,0,5] 8
  in content_primitive p"


end

Theory More_MPoly_Type

(* Author: Alexander Bentkamp, Universität des Saarlandes
*)

theory More_MPoly_Type
imports MPoly_Type
begin

abbreviation "lookup == Poly_Mapping.lookup"
abbreviation "keys == Poly_Mapping.keys"

section "MPpoly Mapping extenion"

lemma lookup_Abs_poly_mapping_when_finite:
assumes "finite S"
shows "lookup (Abs_poly_mapping (λx. f x when xS)) = (λx. f x when xS)"
proof -
  have "finite {x. (f x when xS)  0}" using assms by auto
  then show ?thesis using lookup_Abs_poly_mapping by fast
qed

definition remove_key::"'a  ('a 0 'b::monoid_add)  ('a 0 'b)" where
  "remove_key k0 f = Abs_poly_mapping (λk. lookup f k when k  k0)"

lemma remove_key_lookup:
  "lookup (remove_key k0 f) k = (lookup f k when k  k0)"
unfolding remove_key_def using finite_subset by (simp add: lookup_Abs_poly_mapping)

lemma remove_key_keys: "keys f - {k} = keys (remove_key k f)" (is "?A = ?B")
proof (rule antisym; rule subsetI)
  fix x assume "x  ?A"
  then show "x  ?B" using remove_key_lookup lookup_not_eq_zero_eq_in_keys DiffD1 DiffD2 insertCI
    by (metis (mono_tags, lifting) when_def)
next
  fix x assume "x  ?B"
  then have "lookup (remove_key k f) x  0"  by blast
  then show "x  ?A"
    by (simp add: lookup_not_eq_zero_eq_in_keys remove_key_lookup)
qed


lemma remove_key_sum: "remove_key k f + Poly_Mapping.single k (lookup f k) = f"
proof -
  {
  fix k'
  have rem:"(lookup f k' when k'  k) = lookup (remove_key k f) k'"
    using when_def by (simp add: remove_key_lookup)
  have sin:"(lookup f k when k'=k) =  lookup (Poly_Mapping.single k (lookup f k)) k'"
    by (simp add: lookup_single_not_eq when_def)
  have "lookup f k' = (lookup f k' when k'  k) + ((lookup f k) when k'=k)"
    unfolding when_def by fastforce
  with rem sin have "lookup f k' = lookup ((remove_key k f) + Poly_Mapping.single k (lookup f k)) k'"
    using lookup_add by metis
  }
  then show ?thesis by (metis poly_mapping_eqI)
qed

lemma remove_key_single[simp]: "remove_key v (Poly_Mapping.single v n) = 0"
proof -
 have 0:"k. (lookup (Poly_Mapping.single v n) k when k  v) = 0" by (simp add: lookup_single_not_eq when_def)
 show ?thesis unfolding remove_key_def 0
   by auto
qed

lemma remove_key_add: "remove_key v m + remove_key v m' = remove_key v (m + m')"
  by (rule poly_mapping_eqI; simp add: lookup_add remove_key_lookup when_add_distrib)

lemma poly_mapping_induct [case_names single sum]:
fixes P::"('a, 'b::monoid_add) poly_mapping  bool"
assumes single:"k v. P (Poly_Mapping.single k v)"
and sum:"(f g k v. P f  P g  g = (Poly_Mapping.single k v)  k  keys f  P (f+g))"
shows "P f" using finite_keys[of f]
proof (induction "keys f" arbitrary: f rule: finite_induct)
  case (empty)
  then show ?case using single[of _ 0] by (metis (full_types) aux empty_iff not_in_keys_iff_lookup_eq_zero single_zero)
next
  case (insert k K f)
  obtain f1 f2 where f12_def: "f1 = remove_key k f" "f2 = Poly_Mapping.single k (lookup f k)" by blast
  have "P f1"
  proof -
    have "Suc (card (keys f1)) = card (keys f)"
      using remove_key_keys finite_keys f12_def(1) by (metis (no_types) Diff_insert_absorb card_insert_disjoint insert.hyps(2) insert.hyps(4))
    then show ?thesis using insert lessI by (metis Diff_insert_absorb f12_def(1) remove_key_keys)
  qed
  have "P f2" by (simp add: single f12_def(2))
  have "f1 + f2 = f" using remove_key_sum f12_def by auto
  have "k  keys f1" using remove_key_keys f12_def by fast
  then show ?case using P f1 P f2 sum[of f1 f2 k "lookup f k"] f1 + f2 = f f12_def by auto
qed


lemma map_lookup:
assumes "g 0 = 0"
shows "lookup (Poly_Mapping.map g f) x = g ((lookup f) x)"
proof -
  have "(g (lookup f x) when lookup f x  0) = g (lookup f x)"
    by (metis (mono_tags, lifting) assms when_def)
  then have "(g (lookup f x) when x  keys f) = g (lookup f x)"
    using lookup_not_eq_zero_eq_in_keys [of f] by simp
  then show ?thesis 
    by (simp add: Poly_Mapping.map_def map_fun_def in_keys_iff)
qed

lemma keys_add:
assumes "keys f  keys g = {}"
shows "keys f  keys g = keys (f+g)"
proof
  have "keys f  keys (f+g)"
  proof
    fix x assume "xkeys f"
    then have "lookup (f+g) x = lookup f x " by (metis add.right_neutral assms disjoint_iff_not_equal not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
    then show "xkeys (f+g)" using xkeys f by (metis not_in_keys_iff_lookup_eq_zero)
  qed
  moreover have "keys g  keys (f+g)"
  proof
    fix x assume "xkeys g"
    then have "lookup (f+g) x = lookup g x "  by (metis IntI add.left_neutral assms empty_iff not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
    then show "xkeys (f+g)" using xkeys g by (metis not_in_keys_iff_lookup_eq_zero)
  qed
  ultimately show "keys f  keys g  keys (f+g)" by simp
next
  show "keys (f + g)  keys f  keys g" by (simp add: keys_add)
qed

lemma fun_when:
"f 0 = 0  f (a when P) = (f a when P)" by (simp add: when_def)

section "MPoly extension"

lemma coeff_all_0:"(m. coeff p m = 0)  p=0"
  by (metis aux coeff_def mapping_of_inject zero_mpoly.rep_eq)

definition vars::"'a::zero mpoly  nat set" where
  "vars p =  (keys ` keys (mapping_of p))"

lemma vars_finite: "finite (vars p)" unfolding vars_def by auto

lemma vars_monom_single: "vars (monom (Poly_Mapping.single v k) a)  {v}"
proof
  fix w assume "w  vars (monom (Poly_Mapping.single v k) a)"
  then have "w = v" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
  then show "w  {v}" by auto
qed

lemma vars_monom_keys:
assumes "a0"
shows "vars (monom m a) = keys m"
proof (rule antisym; rule subsetI)
  fix w assume "w  vars (monom m a)"
  then have "lookup m w  0" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
  then show "w  keys m" by (meson lookup_not_eq_zero_eq_in_keys)
next
  fix w assume "w  keys m"
  then have "lookup m w  0" by (meson lookup_not_eq_zero_eq_in_keys)
  then show "w  vars (monom m a)" unfolding vars_def using assms by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq monom.rep_eq)
qed

lemma vars_monom_subset:
shows "vars (monom m a)  keys m"
  by (cases "a=0"; simp add: vars_def vars_monom_keys)

lemma vars_monom_single_cases: "vars (monom (Poly_Mapping.single v k) a) = (if k=0  a=0 then {} else {v})"
proof(cases "k=0")
  assume "k=0"
  then have "(Poly_Mapping.single v k) = 0" by simp
  then have "vars (monom (Poly_Mapping.single v k) a) = {}"
    by (metis (mono_tags, lifting) single_zero singleton_inject subset_singletonD vars_monom_single zero_neq_one)
  then show ?thesis using k=0 by auto
next
  assume "k0"
  then show ?thesis
  proof (cases "a=0")
    assume "a=0"
    then have "monom (Poly_Mapping.single v k) a = 0" by (metis monom.abs_eq monom_zero single_zero)
    then show ?thesis by (metis (mono_tags, hide_lams) k  0 a=0 monom.abs_eq single_zero singleton_inject subset_singletonD vars_monom_single)
  next
    assume "a0"
    then have "v  vars (monom (Poly_Mapping.single v k) a)" by (simp add: k  0 vars_def)
    then show ?thesis using a0 k  0 vars_monom_single by fastforce
  qed
qed

lemma vars_monom:
assumes "a0"
shows "vars (monom m (1::'a::zero_neq_one)) = vars (monom m (a::'a))"
  unfolding vars_monom_keys[OF assms] using vars_monom_keys[of 1] one_neq_zero by blast

lemma vars_add: "vars (p1 + p2)  vars p1  vars p2"
proof
  fix w assume "w  vars (p1 + p2)"
  then obtain m where "w  keys m" "m  keys (mapping_of (p1 + p2))" by (metis UN_E vars_def)
  then have "m  keys (mapping_of (p1))  keys (mapping_of (p2))"
    by (metis Poly_Mapping.keys_add plus_mpoly.rep_eq subset_iff)
  then show "w  vars p1  vars p2" using vars_def w  keys m by fastforce
qed

lemma vars_mult: "vars (p*q)  vars p  vars q"
proof
  fix x assume "xvars (p*q)"
  then obtain m where "mkeys (mapping_of (p*q))" "xkeys m"
    using vars_def  by blast
  then have "mkeys (mapping_of p * mapping_of q)"
    by (simp add: times_mpoly.rep_eq)
  then obtain a b where "m=a + b" "a  keys (mapping_of p)" "b  keys (mapping_of q)"
    using keys_mult by blast
  then have "x  keys a  keys b"
    using Poly_Mapping.keys_add x  keys m by force
  then show "x  vars p  vars q" unfolding vars_def
    using a  keys (mapping_of p) b  keys (mapping_of q) by blast
qed

lemma vars_add_monom:
assumes "p2 = monom m a" "m  keys (mapping_of p1)"
shows "vars (p1 + p2) = vars p1  vars p2"
proof -
  have "keys (mapping_of p2)  {m}" using monom_def keys_single assms by auto
  have "keys (mapping_of (p1+p2)) = keys (mapping_of p1)  keys (mapping_of p2)"
    using keys_add by (metis Int_insert_right_if0 ‹keys (mapping_of p2)  {m} assms(2) inf_bot_right plus_mpoly.rep_eq subset_singletonD)
  then show ?thesis unfolding vars_def by simp
qed

lemma vars_setsum: "finite S  vars (mS. f m)  (mS. vars (f m))"
proof (induction S rule:finite_induct)
  case empty
  then show ?case by (metis UN_empty eq_iff monom_zero sum.empty single_zero vars_monom_single_cases)
next
  case (insert s S)
  then have "vars (sum f (insert s S)) = vars (f s + sum f S)" by (metis sum.insert)
  also have "...  vars (f s)  vars (sum f S)" by (simp add: vars_add)
  also have "...  (minsert s S. vars (f m))" using insert.IH by auto
  finally show ?case by metis
qed

lemma coeff_monom: "coeff (monom m a) m' = (a when m'=m)"
  by (simp add: coeff_def lookup_single_not_eq when_def)

lemma coeff_add: "coeff p m + coeff q m = coeff (p+q) m"
  by (simp add: coeff_def lookup_add plus_mpoly.rep_eq)

lemma coeff_eq: "coeff p = coeff q  p=q" by (simp add: coeff_def lookup_inject mapping_of_inject)

lemma coeff_monom_mult: "coeff ((monom m' a)  * q) (m' + m)  = a * coeff q m"
  unfolding coeff_def times_mpoly.rep_eq lookup_mult mapping_of_monom lookup_single when_mult
  Sum_any_when_equal' Groups.cancel_semigroup_add_class.add_left_cancel by metis

lemma one_term_is_monomial:
assumes "card (keys (mapping_of p))  1"
obtains m where "p = monom m (coeff p m)"
proof (cases "keys (mapping_of p) = {}")
  case True
  then show ?thesis using aux coeff_def empty_iff mapping_of_inject mapping_of_monom not_in_keys_iff_lookup_eq_zero single_zero by (metis (no_types) that)
next
  case False
  then obtain m where "keys (mapping_of p) = {m}" using assms by (metis One_nat_def Suc_leI antisym card_0_eq card_eq_SucD finite_keys neq0_conv)
  have "p = monom m (coeff p m)"
    unfolding mapping_of_inject[symmetric]
    by (rule poly_mapping_eqI, metis (no_types, lifting) ‹keys (mapping_of p) = {m}
    coeff_def keys_single lookup_single_eq  mapping_of_monom not_in_keys_iff_lookup_eq_zero
    singletonD)
  then show ?thesis ..
qed

(* remove_term is eventually unnessecary *)
definition remove_term::"(nat 0 nat)  'a::zero mpoly  'a mpoly" where
  "remove_term m0 p = MPoly (Abs_poly_mapping (λm. coeff p m when m  m0))"

lemma remove_term_coeff: "coeff (remove_term m0 p) m = (coeff p m when m  m0)"
proof -
  have "{m. (coeff p m when m  m0)  0}  {m. coeff p m  0}" by auto
  then have "finite {m. (coeff p m when m  m0)  0}" unfolding coeff_def using finite_subset by auto
  then have "lookup (Abs_poly_mapping (λm. coeff p m when m  m0)) m = (coeff p m when m  m0)" using lookup_Abs_poly_mapping by fastforce
  then show ?thesis unfolding remove_term_def using coeff_def by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed

lemma coeff_keys: "m  keys (mapping_of p)  coeff p m  0"
  by (simp add: coeff_def in_keys_iff)

lemma remove_term_keys:
shows "keys (mapping_of p) - {m} = keys (mapping_of (remove_term m p))" (is "?A = ?B")
proof
  show "?A  ?B"
  proof
    fix m' assume "m'?A"
    then show "m'  ?B" by (simp add: coeff_keys remove_term_coeff)
  qed
  show "?B  ?A"
  proof
    fix m' assume "m' ?B"
    then show "m'  ?A" by (simp add: coeff_keys remove_term_coeff)
  qed
qed


lemma remove_term_sum: "remove_term m p + monom m (coeff p m) = p"
proof -
  have "coeff p = (λm'. (coeff p m' when m'  m) + ((coeff p m) when m'=m))" unfolding when_def by fastforce
  moreover have "coeff (remove_term m p + monom m (coeff p m)) = ..."
    using remove_term_coeff coeff_monom coeff_add by (metis (no_types))
  ultimately show ?thesis using coeff_eq by auto
qed

lemma mpoly_induct [case_names monom sum]:
assumes monom:"m a. P (monom m a)"
and sum:"(p1 p2 m a. P p1  P p2  p2 = (monom m a)  m  keys (mapping_of p1)  P (p1+p2))"
shows "P p" using assms
  using poly_mapping_induct[of "λp :: (nat 0 nat) 0 'a. P (MPoly p)"] MPoly_induct monom.abs_eq plus_mpoly.abs_eq
  by (metis (no_types) MPoly_inverse UNIV_I)

lemma monom_pow:"monom (Poly_Mapping.single v n0) a ^ n = monom (Poly_Mapping.single v (n0*n)) (a ^ n)"
apply (induction n)
apply auto
by (metis (no_types, lifting) mult_monom single_add)

lemma insertion_fun_single: "insertion_fun f (λm. (a when (Poly_Mapping.single (v::nat) (n::nat)) = m)) = a * f v ^ n" (is "?i = _")
proof -
  have setsum_single:" a f. (m{a}. f m) = f a"
   by (metis add.right_neutral empty_Diff finite.emptyI sum.empty sum.insert_remove)

  have 1:"?i = (m. (a when Poly_Mapping.single v n = m) * (v. f v ^ lookup m v))"
    unfolding insertion_fun_def by metis
  have "m. m  Poly_Mapping.single v n  (a when Poly_Mapping.single v n = m) = 0" by simp

  have "(m{Poly_Mapping.single v n}. (a when Poly_Mapping.single v n = m) * (v. f v ^ lookup m v)) = ?i"
    unfolding 1 when_mult unfolding when_def by auto
  then have 2:"?i = a * (va. f va ^ lookup (Poly_Mapping.single v n) va)"
    unfolding setsum_single[of "λm. (a when Poly_Mapping.single v n = m) * (v. f v ^ lookup m v)" "Poly_Mapping.single k v"]
    by auto
  have "v0. v0v  lookup (Poly_Mapping.single v n) v0 = 0" by (simp add: lookup_single_not_eq)
  then have "va. vav  f va ^ lookup (Poly_Mapping.single v n) va = 1"  by simp
  then have "a * (va{v}. f va ^ lookup (Poly_Mapping.single v n) va) = ?i" unfolding 2
    using Prod_any.expand_superset[of "{v}" "λva. f va ^ lookup (Poly_Mapping.single v n) va", simplified]
    by fastforce
  then show ?thesis by simp
qed

lemma insertion_single[simp]: "insertion f (monom (Poly_Mapping.single (v::nat) (n::nat)) a) = a * f v ^ n"
  using insertion_fun_single  Sum_any.cong insertion.rep_eq insertion_aux.rep_eq insertion_fun_def
  mapping_of_monom single.rep_eq by (metis (no_types, lifting))

lemma insertion_fun_irrelevant_vars:
fixes p::"((nat 0 nat)  'a::comm_ring_1)"
assumes "m v. p m  0  lookup m v  0  f v = g v"
shows "insertion_fun f p = insertion_fun g p"
proof -
  {
    fix m::"nat0nat"
    assume "p m  0"
    then have "(v. f v ^ lookup m v) = (v. g v ^ lookup m v)"
      using assms by (metis power_0)
  }
  then show ?thesis unfolding insertion_fun_def by (metis (no_types, lifting) mult_not_zero)
qed

lemma insertion_aux_irrelevant_vars:
fixes p::"((nat 0 nat) 0 'a::comm_ring_1)"
assumes "m v. lookup p m  0  lookup m v  0  f v = g v"
shows "insertion_aux f p = insertion_aux g p"
  using insertion_fun_irrelevant_vars[of "lookup p" f g] assms
  by (metis insertion_aux.rep_eq)

lemma insertion_irrelevant_vars:
fixes p::"'a::comm_ring_1 mpoly"
assumes "v. vvars p  f v = g v"
shows "insertion f p = insertion g p"
proof -
  {
    fix m v assume "lookup (mapping_of p) m  0" "lookup m v  0"
    then have "v  vars p" unfolding vars_def by (meson UN_I lookup_not_eq_zero_eq_in_keys)
    then have "f v = g v" using assms by auto
  }
  then show ?thesis
    unfolding insertion_def using insertion_aux_irrelevant_vars[of "mapping_of p"]
    by (metis insertion.rep_eq insertion_def)
qed

section "Nested MPoly"

definition reduce_nested_mpoly::"'a::comm_ring_1 mpoly mpoly  'a mpoly" where
  "reduce_nested_mpoly pp = insertion (λv. monom (Poly_Mapping.single v 1) 1) pp"

lemma reduce_nested_mpoly_sum:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 + p2) = reduce_nested_mpoly p1 + reduce_nested_mpoly p2"
  by (simp add: insertion_add reduce_nested_mpoly_def)

lemma reduce_nested_mpoly_prod:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 * p2) = reduce_nested_mpoly p1 * reduce_nested_mpoly p2"
  by (simp add: insertion_mult reduce_nested_mpoly_def)

lemma reduce_nested_mpoly_0:
shows "reduce_nested_mpoly 0 = 0" by (simp add: reduce_nested_mpoly_def)

lemma insertion_nested_poly:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (insertion (λv. monom 0 (f v)) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v n)
    show ?case unfolding reduce_nested_mpoly_def
      apply (simp add: insertion_mult monom_pow)
      using monom_pow[of 0 0 "f v" n] apply simp
      using insertion_single[of f 0 0] by auto
  next
    case (sum m1 m2 k v)
    then have "insertion f (insertion (λv. monom 0 (f v)) (monom m1 a * monom m2 1))
             = insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))" unfolding reduce_nested_mpoly_prod insertion_mult by metis
    then show ?case using mult_monom[of m1 a m2 1] by auto
  qed
next
  case (sum p1 p2 m a)
  then show ?case by (simp add: reduce_nested_mpoly_sum insertion_add)
qed

definition extract_var::"'a::comm_ring_1 mpoly  nat  'a::comm_ring_1 mpoly mpoly" where
"extract_var p v = (m. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"

lemma extract_var_finite_set:
assumes "{m'. coeff p m'  0}  S"
assumes "finite S"
shows "extract_var p v = (mS. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
proof-
  {
    fix m' assume "coeff p m' = 0"
    then have "monom (remove_key v m') (monom (Poly_Mapping.single v (lookup m' v)) (coeff p m')) = 0"
      using monom.abs_eq monom_zero single_zero by metis
  }
  then have 0:"{a. monom (remove_key v a) (monom (Poly_Mapping.single v (lookup a v)) (coeff p a))  0}  S"
    using {m'. coeff p m'  0}  S by fastforce
  then show ?thesis
    unfolding extract_var_def using Sum_any.expand_superset [OF ‹finite S 0] by metis
qed

lemma extract_var_non_zero_coeff: "extract_var p v = (m{m'. coeff p m'  0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
  using extract_var_finite_set  coeff_def finite_lookup order_refl by (metis (no_types, lifting) Collect_cong sum.cong)

lemma extract_var_sum: "extract_var (p+p') v = extract_var p v + extract_var p' v"
proof -
  define S where "S = {m. coeff p m  0}  {m. coeff p' m  0}  {m. coeff (p+p') m  0}"
  have subsets:"{m. coeff p m  0}  S" "{m. coeff p' m  0}  S" "{m. coeff (p+p') m  0}  S"
    unfolding S_def by auto
  have "finite S" unfolding S_def using coeff_def finite_lookup
    by (metis (mono_tags) Collect_disj_eq finite_Collect_disjI)
  then show ?thesis  unfolding
    extract_var_finite_set[OF subsets(1) ‹finite S]
    extract_var_finite_set[OF subsets(2) ‹finite S]
    extract_var_finite_set[OF subsets(3) ‹finite S]
    coeff_add[symmetric] monom_add sum.distrib
    by metis
qed



lemma extract_var_monom:
shows "extract_var (monom m a) v = monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) a)"
proof (cases "a = 0")
  assume "a  0"
  have 0:"{m'. coeff (monom m a) m'  0} = {m}"
    unfolding coeff_monom using a  0 by auto
  show ?thesis
    unfolding extract_var_non_zero_coeff unfolding 0 unfolding coeff_monom
    using sum.insert[OF finite.emptyI, unfolded sum.empty add.right_neutral] when_def
    by auto
next
  assume "a = 0"
  have 0:"{m'. coeff (monom m a) m'  0} = {}"
    unfolding coeff_monom using a = 0 by auto
  show ?thesis unfolding extract_var_non_zero_coeff 0
    using a = 0 monom.abs_eq monom_zero sum.empty single_zero by (metis (no_types, lifting))
qed


lemma extract_var_monom_mult:
shows "extract_var (monom (m+m') (a*b)) v = extract_var (monom m a) v * extract_var (monom m' b) v"
unfolding extract_var_monom remove_key_add lookup_add single_add mult_monom by auto

lemma extract_var_single: "extract_var (monom (Poly_Mapping.single v n) a) v = monom 0 (monom (Poly_Mapping.single v n) a)"
unfolding extract_var_monom by simp

lemma extract_var_single':
assumes "v  v'"
shows "extract_var (monom (Poly_Mapping.single v n) a) v' = monom (Poly_Mapping.single v n) (monom 0 a)"
unfolding extract_var_monom using assms by (metis add.right_neutral lookup_single_not_eq remove_key_sum single_zero)

lemma reduce_nested_mpoly_extract_var:
fixes p::"'a::comm_ring_1 mpoly"
shows "reduce_nested_mpoly (extract_var p v) = p"
proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v' n)
    show ?case
    proof (cases "v' = v")
      case True
      then show ?thesis
        by (metis (no_types, lifting) insertion_single mult.right_neutral power_0
        reduce_nested_mpoly_def single_zero extract_var_single)
    next
      case False
      then show ?thesis unfolding extract_var_single'[OF False] reduce_nested_mpoly_def insertion_single
        by (simp add: monom_pow mult_monom)
    qed
  next
    case (sum m m' v n a)
    then show ?case
      using extract_var_monom_mult[of m m' a 1] reduce_nested_mpoly_prod by (metis mult.right_neutral mult_monom)
  qed
next
  case (sum p1 p2 m a)
  then show ?case unfolding extract_var_sum reduce_nested_mpoly_sum by auto
qed


lemma vars_extract_var_subset: "vars (extract_var p v)  vars p"
proof
  have "finite {m'. coeff p m'  0}" by (simp add: coeff_def)
  fix x assume "x  vars (extract_var p v)"
  then have "x  vars (m{m'. coeff p m'  0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    unfolding extract_var_non_zero_coeff by metis
  then have "x  (m{m'. coeff p m'  0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
    using vars_setsum[OF ‹finite {m'. coeff p m'  0}] by auto
  then obtain m where "m{m'. coeff p m'  0}" "x  vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    by blast
  show "x  vars p" by (metis (mono_tags, lifting) DiffD1 UN_I m  {m'. coeff p m'  0}
    x  vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))
    coeff_keys mem_Collect_eq remove_key_keys subsetCE vars_def vars_monom_subset)
qed

lemma v_not_in_vars_extract_var: "v  vars (extract_var p v)"
proof -
  have "finite {m'. coeff p m'  0}" by (simp add: coeff_def)
  have "m. m{m'. coeff p m'  0}  v  vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    by (metis Diff_iff remove_key_keys singletonI subsetCE vars_monom_subset)
  then have "v  (m{m'. coeff p m'  0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
    by simp
  then show ?thesis
   unfolding extract_var_non_zero_coeff using vars_setsum[OF ‹finite {m'. coeff p m'  0}] by blast
qed

lemma vars_coeff_extract_var: "vars (coeff (extract_var p v) j)  {v}"
proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case unfolding extract_var_monom coeff_monom vars_monom_single_cases
    by (metis monom_zero single_zero vars_monom_single when_def)
next
  case (sum p1 p2 m a)
  then show ?case unfolding extract_var_sum coeff_add[symmetric]
    by (metis (no_types, lifting) Un_insert_right insert_absorb2 subset_insertI2 subset_singletonD sup_bot.right_neutral vars_add)
qed

definition replace_coeff
where "replace_coeff f p = MPoly (Abs_poly_mapping (λm. f (lookup (mapping_of p) m)))"

lemma coeff_replace_coeff:
assumes "f 0 = 0"
shows "coeff (replace_coeff f p) m = f (coeff p m)"
proof -
  have 0:"finite {m. f (lookup (mapping_of p) m)  0}"
    unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
  then show ?thesis unfolding replace_coeff_def coeff_def using lookup_Abs_poly_mapping[OF 0]
    by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed

lemma replace_coeff_monom:
assumes "f 0 = 0"
shows "replace_coeff f (monom m a) = monom m (f a)"
  unfolding replace_coeff_def
  unfolding  mapping_of_inject[symmetric] lookup_inject[symmetric] apply (rule HOL.ext)
  unfolding lookup_single  mapping_of_monom fun_when[of f, OF f 0 = 0]
  by (metis coeff_def coeff_monom lookup_single lookup_single_not_eq monom.abs_eq single.abs_eq)

lemma replace_coeff_add:
assumes "f 0 = 0"
assumes "a b. f (a+b) = f a + f b"
shows "replace_coeff f (p1 + p2) = replace_coeff f p1 + replace_coeff f p2"
proof -
  have "finite {m. f (lookup (mapping_of p1) m)  0}"
       "finite {m. f (lookup (mapping_of p2) m)  0}"
    unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
  then show ?thesis
    unfolding replace_coeff_def plus_mpoly.rep_eq unfolding Poly_Mapping.plus_poly_mapping.rep_eq
    unfolding assms(2) plus_mpoly.abs_eq using Poly_Mapping.plus_poly_mapping.abs_eq[unfolded eq_onp_def] by fastforce
qed

lemma insertion_replace_coeff:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (replace_coeff (insertion f) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v n)
    show ?case unfolding reduce_nested_mpoly_def  unfolding replace_coeff_monom[of "insertion f", OF insertion_zero]
      insertion_single insertion_mult using insertion_single by (simp add: monom_pow)
  next
    case (sum m1 m2 k v)
    have "replace_coeff (insertion f) (monom m1 a * monom m2 1) = replace_coeff (insertion f) (monom m1 a) * replace_coeff (insertion f) (monom m2 1)"
      by (simp add: mult_monom replace_coeff_monom)
    then have "insertion f (replace_coeff (insertion f) (monom m1 a * monom m2 1)) = insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))"
      unfolding reduce_nested_mpoly_prod insertion_mult
      by (simp add: insertion_mult sum.IH(1) sum.IH(2))
    then show ?case using mult_monom[of m1 a m2 1] by auto
  qed
next
  case (sum p1 p2 m a)
  then show ?case using reduce_nested_mpoly_sum insertion_add
    replace_coeff_add[of "insertion f", OF insertion_zero insertion_add] by metis
qed

lemma replace_coeff_extract_var_cong:
assumes "f v = g v"
shows "replace_coeff (insertion f) (extract_var p v) = replace_coeff (insertion g) (extract_var p v)"
  by (induction p rule:mpoly_induct;simp add: assms extract_var_monom replace_coeff_monom
  extract_var_sum insertion_add replace_coeff_add)

lemma vars_replace_coeff:
assumes "f 0 = 0"
shows "vars (replace_coeff f p)  vars p"
  unfolding vars_def apply (rule subsetI) unfolding mem_simps(8) coeff_keys
  using assms coeff_replace_coeff by (metis coeff_keys)

(* Polynomial functions *)

definition polyfun :: "nat set  ((nat  'a::comm_semiring_1)  'a)  bool"
  where "polyfun N f = (p. vars p  N  (x. insertion x p = f x))"

lemma polyfunI: "(P. (p. vars p  N  (x. insertion x p = f x)  P)  P)  polyfun N f"
  unfolding polyfun_def by metis

lemma polyfun_subset: "NN'  polyfun N f  polyfun N' f"
  unfolding polyfun_def by blast

lemma polyfun_const: "polyfun N (λ_. c)"
proof -
  have "x. insertion x (monom 0 c) = c" using insertion_single by (metis insertion_one monom_one mult.commute mult.right_neutral single_zero)
  then show ?thesis unfolding polyfun_def by (metis (full_types) empty_iff keys_single single_zero subsetI subset_antisym vars_monom_subset)
qed

lemma polyfun_add:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (λx. f x + g x)"
proof -
  obtain p1 p2 where "vars p1  N" "x. insertion x p1 = f x"
                     "vars p2  N" "x. insertion x p2 = g x"
    using polyfun_def assms by metis
  then have "vars (p1 + p2)  N" "x. insertion x (p1 + p2) = f x + g x"
    using vars_add using Un_iff subsetCE subsetI apply blast
    by (simp add: x. insertion x p1 = f x x. insertion x p2 = g x insertion_add)
  then show ?thesis using polyfun_def by blast
qed

lemma polyfun_mult:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (λx. f x * g x)"
proof -
  obtain p1 p2 where "vars p1  N" "x. insertion x p1 = f x"
                     "vars p2  N" "x. insertion x p2 = g x"
    using polyfun_def assms by metis
  then have "vars (p1 * p2)  N" "x. insertion x (p1 * p2) = f x * g x"
    using vars_mult using Un_iff subsetCE subsetI apply blast
    by (simp add: x. insertion x p1 = f x x. insertion x p2 = g x insertion_mult)
  then show ?thesis using polyfun_def by blast
qed

lemma polyfun_Sum:
assumes "finite I"
assumes "i. iI  polyfun N (f i)"
shows "polyfun N (λx. iI. f i x)"
  using assms
  apply (induction I rule:finite_induct)
  apply (simp add: polyfun_const)
  using comm_monoid_add_class.sum.insert polyfun_add by fastforce

lemma polyfun_Prod:
assumes "finite I"
assumes "i. iI  polyfun N (f i)"
shows "polyfun N (λx. iI. f i x)"
  using assms
  apply (induction I rule:finite_induct)
  apply (simp add: polyfun_const)
  using comm_monoid_add_class.sum.insert polyfun_mult by fastforce

lemma polyfun_single:
assumes "iN"
shows "polyfun N (λx. x i)"
proof -
  have "f. insertion f (monom (Poly_Mapping.single i 1) 1) = f i" using insertion_single by simp
  then show ?thesis unfolding polyfun_def
    using vars_monom_single[of i 1 1] One_nat_def assms singletonD subset_eq
    by blast
qed

end

Theory Power_Products

(* Author: Fabian Immler, Alexander Maletzky *)

section ‹Abstract Power-Products›

theory Power_Products
  imports Complex_Main
  "HOL-Library.Function_Algebras"
  "HOL-Library.Countable"
  "More_MPoly_Type"
  "Utils"
  Well_Quasi_Orders.Well_Quasi_Orders
begin

text ‹This theory formalizes the concept of "power-products". A power-product can be thought of as
  the product of some indeterminates, such as $x$, $x^2\,y$, $x\,y^3\,z^7$, etc., without any
  scalar coefficient.

The approach in this theory is to capture the notion of "power-product" (also called "monomial") as
type class. A canonical instance for power-product is the type @{typ "'var 0 nat"}, which is
interpreted as mapping from variables in the power-product to exponents.

A slightly unintuitive (but fitting better with the standard type class instantiations of
@{typ "'a 0 'b"}) approach is to write addition to denote "multiplication" of power products.
For example, $x^2y$ would be represented as a function p = (X ↦ 2, Y ↦ 1)›, $xz$ as a
function q = (X ↦ 1, Z ↦ 1)›. With the (pointwise) instantiation of addition of @{typ "'a 0 'b"},
we will write p + q = (X ↦ 3, Y ↦ 1, Z ↦ 1)› for the product $x^2y \cdot xz = x^3yz$
›

subsection ‹Constant @{term Keys}

text ‹Legacy:›
lemmas keys_eq_empty_iff = keys_eq_empty

definition Keys :: "('a 0 'b::zero) set  'a set"
  where "Keys F = (keys ` F)"

lemma in_Keys: "s  Keys F  (fF. s  keys f)"
  unfolding Keys_def by simp

lemma in_KeysI:
  assumes "s  keys f" and "f  F"
  shows "s  Keys F"
  unfolding in_Keys using assms ..

lemma in_KeysE:
  assumes "s  Keys F"
  obtains f where "s  keys f" and "f  F"
  using assms unfolding in_Keys ..

lemma Keys_mono:
  assumes "A  B"
  shows "Keys A  Keys B"
  using assms by (auto simp add: Keys_def)

lemma Keys_insert: "Keys (insert a A) = keys a  Keys A"
  by (simp add: Keys_def)

lemma Keys_Un: "Keys (A  B) = Keys A  Keys B"
  by (simp add: Keys_def)

lemma finite_Keys:
  assumes "finite A"
  shows "finite (Keys A)"
  unfolding Keys_def by (rule, fact assms, rule finite_keys)

lemma Keys_not_empty:
  assumes "a  A" and "a  0"
  shows "Keys A  {}"
proof
  assume "Keys A = {}"
  from a  0 have "keys a  {}" using aux by fastforce
  then obtain s where "s  keys a" by blast
  from this assms(1) have "s  Keys A" by (rule in_KeysI)
  with ‹Keys A = {} show False by simp
qed

lemma Keys_empty [simp]: "Keys {} = {}"
  by (simp add: Keys_def)

lemma Keys_zero [simp]: "Keys {0} = {}"
  by (simp add: Keys_def)

lemma keys_subset_Keys:
  assumes "f  F"
  shows "keys f  Keys F"
  using in_KeysI[OF _ assms] by auto

lemma Keys_minus: "Keys (A - B)  Keys A"
  by (auto simp add: Keys_def)

lemma Keys_minus_zero: "Keys (A - {0}) = Keys A"
proof (cases "0  A")
  case True
  hence "(A - {0})  {0} = A" by auto
  hence "Keys A = Keys ((A - {0})  {0})" by simp
  also have "... = Keys (A - {0})  Keys {0::('a 0 'b)}" by (fact Keys_Un)
  also have "... = Keys (A - {0})" by simp
  finally show ?thesis by simp
next
  case False
  hence "A - {0} = A" by simp
  thus ?thesis by simp
qed

subsection ‹Constant @{term except}

definition except_fun :: "('a  'b)  'a set  ('a  'b::zero)"
  where "except_fun f S = (λx. (f x when x  S))"

lift_definition except :: "('a 0 'b)  'a set  ('a 0 'b::zero)" is except_fun
proof -
  fix p::"'a  'b" and S::"'a set"
  assume "finite {t. p t  0}"
  show "finite {t. except_fun p S t  0}"
  proof (rule finite_subset[of _ "{t. p t  0}"], rule)
    fix u
    assume "u  {t. except_fun p S t  0}"
    hence "p u  0" by (simp add: except_fun_def)
    thus "u  {t. p t  0}" by simp
  qed fact
qed

lemma lookup_except_when: "lookup (except p S) = (λt. lookup p t when t  S)"
  by (auto simp: except.rep_eq except_fun_def)

lemma lookup_except: "lookup (except p S) = (λt. if t  S then 0 else lookup p t)"
  by (rule ext) (simp add: lookup_except_when)

lemma lookup_except_singleton: "lookup (except p {t}) t = 0"
  by (simp add: lookup_except)

lemma except_zero [simp]: "except 0 S = 0"
  by (rule poly_mapping_eqI) (simp add: lookup_except)

lemma lookup_except_eq_idI:
  assumes "t  S"
  shows "lookup (except p S) t = lookup p t"
  using assms by (simp add: lookup_except)

lemma lookup_except_eq_zeroI:
  assumes "t  S"
  shows "lookup (except p S) t = 0"
  using assms by (simp add: lookup_except)

lemma except_empty [simp]: "except p {} = p"
  by (rule poly_mapping_eqI) (simp add: lookup_except)

lemma except_eq_zeroI:
  assumes "keys p  S"
  shows "except p S = 0"
proof (rule poly_mapping_eqI, simp)
  fix t
  show "lookup (except p S) t = 0"
  proof (cases "t  S")
    case True
    thus ?thesis by (rule lookup_except_eq_zeroI)
  next
    case False then show ?thesis
      by (metis assms in_keys_iff lookup_except_eq_idI subset_eq) 
  qed
qed

lemma except_eq_zeroE:
  assumes "except p S = 0"
  shows "keys p  S"
  by (metis assms aux in_keys_iff lookup_except_eq_idI subset_iff)

lemma except_eq_zero_iff: "except p S = 0  keys p  S"
  by (rule, elim except_eq_zeroE, elim except_eq_zeroI)

lemma except_keys [simp]: "except p (keys p) = 0"
  by (rule except_eq_zeroI, rule subset_refl)

lemma plus_except: "p = Poly_Mapping.single t (lookup p t) + except p {t}"
  by (rule poly_mapping_eqI, simp add: lookup_add lookup_single lookup_except when_def split: if_split)

lemma keys_except: "keys (except p S) = keys p - S"
  by (transfer, auto simp: except_fun_def)

lemma except_single: "except (Poly_Mapping.single u c) S = (Poly_Mapping.single u c when u  S)"
  by (rule poly_mapping_eqI) (simp add: lookup_except lookup_single when_def)

lemma except_plus: "except (p + q) S = except p S + except q S"
  by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)

lemma except_minus: "except (p - q) S = except p S - except q S"
  by (rule poly_mapping_eqI) (simp add: lookup_except lookup_minus)

lemma except_uminus: "except (- p) S = - except p S"
  by (rule poly_mapping_eqI) (simp add: lookup_except)

lemma except_except: "except (except p S) T = except p (S  T)"
  by (rule poly_mapping_eqI) (simp add: lookup_except)

lemma poly_mapping_keys_eqI:
  assumes a1: "keys p = keys q" and a2: "t. t  keys p  lookup p t = lookup q t"
  shows "p = q"
proof (rule poly_mapping_eqI)
  fix t
  show "lookup p t = lookup q t"
  proof (cases "t  keys p")
    case True
    thus ?thesis by (rule a2)
  next
    case False
    moreover from this have "t  keys q" unfolding a1 .
    ultimately have "lookup p t = 0" and "lookup q t = 0" unfolding in_keys_iff by simp_all
    thus ?thesis by simp
  qed
qed

lemma except_id_iff: "except p S = p  keys p  S = {}"
  by (metis Diff_Diff_Int Diff_eq_empty_iff Diff_triv inf_le2 keys_except lookup_except_eq_idI
      lookup_except_eq_zeroI not_in_keys_iff_lookup_eq_zero poly_mapping_keys_eqI)

lemma keys_subset_wf:
  "wfP (λp q::('a, 'b::zero) poly_mapping. keys p  keys q)"
unfolding wfP_def
proof (intro wfI_min)
  fix x::"('a, 'b) poly_mapping" and Q
  assume x_in: "x  Q"
  let ?Q0 = "card ` keys ` Q"
  from x_in have "card (keys x)  ?Q0" by simp
  from wfE_min[OF wf this] obtain z0
    where z0_in: "z0  ?Q0" and z0_min: "y. (y, z0)  {(x, y). x < y}  y  ?Q0" by auto
  from z0_in obtain z where z0_def: "z0 = card (keys z)" and "z  Q" by auto
  show "zQ. y. (y, z)  {(p, q). keys p  keys q}  y  Q"
  proof (intro bexI[of _ z], rule, rule)
    fix y::"('a, 'b) poly_mapping"
    let ?y0 = "card (keys y)"
    assume "(y, z)  {(p, q). keys p  keys q}"
    hence "keys y  keys z" by simp
    hence "?y0 < z0" unfolding z0_def by (simp add: psubset_card_mono) 
    hence "(?y0, z0)  {(x, y). x < y}" by simp
    from z0_min[OF this] show "y  Q" by auto
  qed (fact)
qed

lemma poly_mapping_except_induct:
  assumes base: "P 0" and ind: "p t. p  0  t  keys p  P (except p {t})  P p"
  shows "P p"
proof (induct rule: wfP_induct[OF keys_subset_wf])
  fix p::"('a, 'b) poly_mapping"
  assume "q. keys q  keys p  P q"
  hence IH: "q. keys q  keys p  P q" by simp
  show "P p"
  proof (cases "p = 0")
    case True
    thus ?thesis using base by simp
  next
    case False
    hence "keys p  {}" by simp
    then obtain t where "t  keys p" by blast
    show ?thesis
    proof (rule ind, fact, fact, rule IH, simp only: keys_except, rule, rule Diff_subset, rule)
      assume "keys p - {t} = keys p"
      hence "t  keys p" by blast
      from this t  keys p show False ..
    qed
  qed
qed

lemma poly_mapping_except_induct':
  assumes "p. (t. t  keys p  P (except p {t}))  P p"
  shows "P p"
proof (induct "card (keys p)" arbitrary: p)
  case 0
  with finite_keys[of p] have "keys p = {}" by simp
  show ?case by (rule assms, simp add: ‹keys p = {})
next
  case step: (Suc n)
  show ?case
  proof (rule assms)
    fix t
    assume "t  keys p"
    show "P (except p {t})"
    proof (rule step(1), simp add: keys_except)
      from step(2) t  keys p finite_keys[of p] show "n = card (keys p - {t})" by simp
    qed
  qed
qed

lemma poly_mapping_plus_induct:
  assumes "P 0" and "p c t. c  0  t  keys p  P p  P (Poly_Mapping.single t c + p)"
  shows "P p"
proof (induct "card (keys p)" arbitrary: p)
  case 0
  with finite_keys[of p] have "keys p = {}" by simp
  hence "p = 0" by simp
  with assms(1) show ?case by simp
next
  case step: (Suc n)
  from step(2) obtain t where t: "t  keys p" by (metis card_eq_SucD insert_iff)
  define c where "c = lookup p t"
  define q where "q = except p {t}"
  have *: "p = Poly_Mapping.single t c + q"
    by (rule poly_mapping_eqI, simp add: lookup_add lookup_single Poly_Mapping.when_def, intro conjI impI,
        simp add: q_def lookup_except c_def, simp add: q_def lookup_except_eq_idI)
  show ?case
  proof (simp only: *, rule assms(2))
    from t show "c  0"
      using c_def by auto
  next
    show "t  keys q" by (simp add: q_def keys_except)
  next
    show "P q"
    proof (rule step(1))
      from step(2) t  keys p show "n = card (keys q)" unfolding q_def keys_except
        by (metis Suc_inject card.remove finite_keys)
    qed
  qed
qed

lemma except_Diff_singleton: "except p (keys p - {t}) = Poly_Mapping.single t (lookup p t)"
  by (rule poly_mapping_eqI) (simp add: lookup_single in_keys_iff lookup_except when_def)

lemma except_Un_plus_Int: "except p (U  V) + except p (U  V) = except p U + except p V"
  by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)

corollary except_Int:
  assumes "keys p  U  V"
  shows "except p (U  V) = except p U + except p V"
proof -
  from assms have "except p (U  V) = 0" by (rule except_eq_zeroI)
  hence "except p (U  V) = except p (U  V) + except p (U  V)" by simp
  also have " = except p U + except p V" by (fact except_Un_plus_Int)
  finally show ?thesis .
qed

lemma except_keys_Int [simp]: "except p (keys p  U) = except p U"
  by (rule poly_mapping_eqI) (simp add: in_keys_iff lookup_except)

lemma except_Int_keys [simp]: "except p (U  keys p) = except p U"
  by (simp only: Int_commute[of U] except_keys_Int)

lemma except_keys_Diff: "except p (keys p - U) = except p (- U)"
proof -
  have "except p (keys p - U) = except p (keys p  (- U))" by (simp only: Diff_eq)
  also have " = except p (- U)" by simp
  finally show ?thesis .
qed

lemma except_decomp: "p = except p U + except p (- U)"
  by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)

corollary except_Compl: "except p (- U) = p - except p U"
  by (metis add_diff_cancel_left' except_decomp)

subsection ‹'Divisibility' on Additive Structures›

context plus begin

definition adds :: "'a  'a  bool" (infix "adds" 50)
  where "b adds a  (k. a = b + k)"

lemma addsI [intro?]: "a = b + k  b adds a"
  unfolding adds_def ..

lemma addsE [elim?]: "b adds a  (k. a = b + k  P)  P"
  unfolding adds_def by blast

end

context comm_monoid_add
begin

lemma adds_refl [simp]: "a adds a"
proof
  show "a = a + 0" by simp
qed

lemma adds_trans [trans]:
  assumes "a adds b" and "b adds c"
  shows "a adds c"
proof -
  from assms obtain v where "b = a + v"
    by (auto elim!: addsE)
  moreover from assms obtain w where "c = b + w"
    by (auto elim!: addsE)
  ultimately have "c = a + (v + w)"
    by (simp add: add.assoc)
  then show ?thesis ..
qed

lemma subset_divisors_adds: "{c. c adds a}  {c. c adds b}  a adds b"
  by (auto simp add: subset_iff intro: adds_trans)

lemma strict_subset_divisors_adds: "{c. c adds a}  {c. c adds b}  a adds b  ¬ b adds a"
  by (auto simp add: subset_iff intro: adds_trans)

lemma zero_adds [simp]: "0 adds a"
  by (auto intro!: addsI)

lemma adds_plus_right [simp]: "a adds c  a adds (b + c)"
  by (auto intro!: add.left_commute addsI elim!: addsE)

lemma adds_plus_left [simp]: "a adds b  a adds (b + c)"
  using adds_plus_right [of a b c] by (simp add: ac_simps)

lemma adds_triv_right [simp]: "a adds b + a"
  by (rule adds_plus_right) (rule adds_refl)

lemma adds_triv_left [simp]: "a adds a + b"
  by (rule adds_plus_left) (rule adds_refl)

lemma plus_adds_mono:
  assumes "a adds b"
    and "c adds d"
  shows "a + c adds b + d"
proof -
  from a adds b obtain b' where "b = a + b'" ..
  moreover from c adds d obtain d' where "d = c + d'" ..
  ultimately have "b + d = (a + c) + (b' + d')"
    by (simp add: ac_simps)
  then show ?thesis ..
qed

lemma plus_adds_left: "a + b adds c  a adds c"
  by (simp add: adds_def add.assoc) blast

lemma plus_adds_right: "a + b adds c  b adds c"
  using plus_adds_left [of b a c] by (simp add: ac_simps)

end

class ninv_comm_monoid_add = comm_monoid_add +
  assumes plus_eq_zero: "s + t = 0  s = 0"
begin

lemma plus_eq_zero_2: "t = 0" if "s + t = 0"
  using that
  by (simp only: add_commute[of s t] plus_eq_zero)

lemma adds_zero: "s adds 0  (s = 0)"
proof
  assume "s adds 0"
  from this obtain k where "0 = s + k" unfolding adds_def ..
  from this plus_eq_zero[of s k] show "s = 0"
    by blast
next
  assume "s = 0"
  thus "s adds 0" by simp
qed

end

context canonically_ordered_monoid_add
begin
subclass ninv_comm_monoid_add by (standard, simp)
end

class comm_powerprod = cancel_comm_monoid_add
begin

lemma adds_canc: "s + u adds t + u  s adds t" for s t u::'a
  unfolding adds_def
  apply auto
   apply (metis local.add.left_commute local.add_diff_cancel_left' local.add_diff_cancel_right')
  using add_assoc add_commute by auto

lemma adds_canc_2: "u + s adds u + t  s adds t"
  by (simp add: adds_canc ac_simps)

lemma add_minus_2: "(s + t) - s = t"
  by simp

lemma adds_minus:
  assumes "s adds t"
  shows "(t - s) + s = t"
proof -
  from assms adds_def[of s t] obtain u where u: "t = u + s" by (auto simp: ac_simps)
  then have "t - s = u"
    by simp
  thus ?thesis using u by simp
qed

lemma plus_adds_0:
  assumes "(s + t) adds u"
  shows "s adds (u - t)"
proof -
  from assms have "(s + t) adds ((u - t) + t)" using adds_minus local.plus_adds_right by presburger
  thus ?thesis using adds_canc[of s t "u - t"] by simp
qed

lemma plus_adds_2:
  assumes "t adds u" and "s adds (u - t)"
  shows "(s + t) adds u"
  by (metis adds_canc adds_minus assms)

lemma plus_adds:
  shows "(s + t) adds u  (t adds u  s adds (u - t))"
proof
  assume a1: "(s + t) adds u"
  show "t adds u  s adds (u - t)"
  proof
    from plus_adds_right[OF a1] show "t adds u" .
  next
    from plus_adds_0[OF a1] show "s adds (u - t)" .
  qed
next
  assume "t adds u  s adds (u - t)"
  hence "t adds u" and "s adds (u - t)" by auto
  from plus_adds_2[OF t adds u s adds (u - t)] show "(s + t) adds u" .
qed

lemma minus_plus:
  assumes "s adds t"
  shows "(t - s) + u = (t + u) - s"
proof -
  from assms obtain k where k: "t = s + k" unfolding adds_def ..
  hence "t - s = k" by simp
  also from k have "(t + u) - s = k + u"
    by (simp add: add_assoc)
  finally show ?thesis by simp
qed

lemma minus_plus_minus:
  assumes "s adds t" and "u adds v"
  shows "(t - s) + (v - u) = (t + v) - (s + u)"
  using add_commute assms(1) assms(2) diff_diff_add minus_plus by auto

lemma minus_plus_minus_cancel:
  assumes "u adds t" and "s adds u"
  shows "(t - u) + (u - s) = t - s"
  by (metis assms(1) assms(2) local.add_diff_cancel_left' local.add_diff_cancel_right local.addsE minus_plus)

end

text ‹Instances of class lcs_powerprod› are types of commutative power-products admitting
  (not necessarily unique) least common sums (inspired from least common multiplies).
  Note that if the components of indeterminates are arbitrary integers (as for instance in Laurent
  polynomials), then no unique lcss exist.›
class lcs_powerprod = comm_powerprod +
  fixes lcs::"'a  'a  'a"
  assumes adds_lcs: "s adds (lcs s t)"
  assumes lcs_adds: "s adds u  t adds u  (lcs s t) adds u"
  assumes lcs_comm: "lcs s t = lcs t s"
begin

lemma adds_lcs_2: "t adds (lcs s t)"
  by (simp only: lcs_comm[of s t], rule adds_lcs)

lemma lcs_adds_plus: "lcs s t adds s + t" by (simp add: lcs_adds)

text ‹"gcs" stands for "greatest common summand".›
definition gcs :: "'a  'a  'a" where "gcs s t = (s + t) - (lcs s t)"

lemma gcs_plus_lcs: "(gcs s t) + (lcs s t) = s + t"
  unfolding gcs_def by (rule adds_minus, fact lcs_adds_plus)

lemma gcs_adds: "(gcs s t) adds s"
proof -
  have "t adds (lcs s t)" (is "t adds ?l") unfolding lcs_comm[of s t] by (fact adds_lcs)
  then obtain u where eq1: "?l = t + u" unfolding adds_def ..
  from lcs_adds_plus[of s t] obtain v where eq2: "s + t = ?l + v" unfolding adds_def ..
  hence "t + s = t + (u + v)" unfolding eq1 by (simp add: ac_simps)
  hence s: "s = u + v" unfolding add_left_cancel .
  show ?thesis unfolding eq2 gcs_def unfolding s by simp
qed

lemma gcs_comm: "gcs s t = gcs t s" unfolding gcs_def by (simp add: lcs_comm ac_simps)

lemma gcs_adds_2: "(gcs s t) adds t"
  by (simp only: gcs_comm[of s t], rule gcs_adds)

end

class ulcs_powerprod = lcs_powerprod + ninv_comm_monoid_add
begin

lemma adds_antisym:
  assumes "s adds t" "t adds s"
  shows "s = t"
proof -
  from s adds t obtain u where u_def: "t = s + u" unfolding adds_def ..
  from t adds s obtain v where v_def: "s = t + v" unfolding adds_def ..
  from u_def v_def have "s = (s + u) + v" by (simp add: ac_simps)
  hence "s + 0 = s + (u + v)" by (simp add: ac_simps)
  hence "u + v = 0" by simp
  hence "u = 0" using plus_eq_zero[of u v] by simp
  thus ?thesis using u_def by simp
qed

lemma lcs_unique:
  assumes "s adds l" and "t adds l" and *: "u. s adds u  t adds u  l adds u"
  shows "l = lcs s t"
  by (rule adds_antisym, rule *, fact adds_lcs, fact adds_lcs_2, rule lcs_adds, fact+)

lemma lcs_zero: "lcs 0 t = t"
  by (rule lcs_unique[symmetric], fact zero_adds, fact adds_refl)

lemma lcs_plus_left: "lcs (u + s) (u + t) = u + lcs s t" 
proof (rule lcs_unique[symmetric], simp_all only: adds_canc_2, fact adds_lcs, fact adds_lcs_2,
    simp add: add.commute[of u] plus_adds)
  fix v
  assume "u adds v  s adds v - u"
  hence "s adds v - u" ..
  assume "t adds v - u"
  with s adds v - u show "lcs s t adds v - u" by (rule lcs_adds)
qed

lemma lcs_plus_right: "lcs (s + u) (t + u) = (lcs s t) + u"
  using lcs_plus_left[of u s t] by (simp add: ac_simps)

lemma adds_gcs:
  assumes "u adds s" and "u adds t"
  shows "u adds (gcs s t)"
proof -
  from assms have "s + u adds s + t" and "t + u adds t + s"
    by (simp_all add: plus_adds_mono)
  hence "lcs (s + u) (t + u) adds s + t"
    by (auto intro: lcs_adds simp add: ac_simps)
  hence "u + (lcs s t) adds s + t" unfolding lcs_plus_right by (simp add: ac_simps)
  hence "u adds (s + t) - (lcs s t)" unfolding plus_adds ..
  thus ?thesis unfolding gcs_def .
qed

lemma gcs_unique:
  assumes "g adds s" and "g adds t" and *: "u. u adds s  u adds t  u adds g"
  shows "g = gcs s t"
  by (rule adds_antisym, rule adds_gcs, fact, fact, rule *, fact gcs_adds, fact gcs_adds_2)

lemma gcs_plus_left: "gcs (u + s) (u + t) = u + gcs s t"
proof -
  have "u + s + (u + t) - (u + lcs s t) = u + s + (u + t) - u - lcs s t" by (simp only: diff_diff_add)
  also have "... = u + s + t + (u - u) - lcs s t" by (simp add: add.left_commute)
  also have "... = u + s + t - lcs s t" by simp
  also have "... =  u + (s + t - lcs s t)"
    using add_assoc add_commute local.lcs_adds_plus local.minus_plus by auto
  finally show ?thesis unfolding gcs_def lcs_plus_left .
qed

lemma gcs_plus_right: "gcs (s + u) (t + u) = (gcs s t) + u"
  using gcs_plus_left[of u s t] by (simp add: ac_simps)

lemma lcs_same [simp]: "lcs s s = s"
proof -
  have "lcs s s adds s" by (rule lcs_adds, simp_all)
  moreover have "s adds lcs s s" by (rule adds_lcs)
  ultimately show ?thesis by (rule adds_antisym)
qed

lemma gcs_same [simp]: "gcs s s = s"
proof -
  have "gcs s s adds s" by (rule gcs_adds)
  moreover have "s adds gcs s s" by (rule adds_gcs, simp_all)
  ultimately show ?thesis by (rule adds_antisym)
qed

end

subsection ‹Dickson Classes›

definition (in plus) dickson_grading :: "('a  nat)  bool"
  where "dickson_grading d 
          ((s t. d (s + t) = max (d s) (d t))  (n::nat. almost_full_on (adds) {x. d x  n}))"

definition dgrad_set :: "('a  nat)  nat  'a set"
  where "dgrad_set d m = {t. d t  m}"

definition dgrad_set_le :: "('a  nat)  ('a set)  ('a set)  bool"
  where "dgrad_set_le d S T  (sS. tT. d s  d t)"

lemma dickson_gradingI:
  assumes "s t. d (s + t) = max (d s) (d t)"
  assumes "n::nat. almost_full_on (adds) {x. d x  n}"
  shows "dickson_grading d"
  unfolding dickson_grading_def using assms by blast

lemma dickson_gradingD1: "dickson_grading d  d (s + t) = max (d s) (d t)"
  by (auto simp add: dickson_grading_def)

lemma dickson_gradingD2: "dickson_grading d  almost_full_on (adds) {x. d x  n}"
  by (auto simp add: dickson_grading_def)

lemma dickson_gradingD2':
  assumes "dickson_grading (d::'a::comm_monoid_add  nat)"
  shows "wqo_on (adds) {x. d x  n}"
proof (intro wqo_onI transp_onI)
  fix x y z :: 'a
  assume "x adds y" and "y adds z"
  thus "x adds z" by (rule adds_trans)
next
  from assms show "almost_full_on (adds) {x. d x  n}" by (rule dickson_gradingD2)
qed

lemma dickson_gradingE:
  assumes "dickson_grading d" and "i::nat. d ((seq::nat  'a::plus) i)  n"
  obtains i j where "i < j" and "seq i adds seq j"
proof -
  from assms(1) have "almost_full_on (adds) {x. d x  n}" by (rule dickson_gradingD2)
  moreover from assms(2) have "i. seq i  {x. d x  n}" by simp
  ultimately obtain i j where "i < j" and "seq i adds seq j" by (rule almost_full_onD)
  thus ?thesis ..
qed

lemma dickson_grading_adds_imp_le:
  assumes "dickson_grading d" and "s adds t"
  shows "d s  d t"
proof -
  from assms(2) obtain u where "t = s + u" ..
  hence "d t = max (d s) (d u)" by (simp only: dickson_gradingD1[OF assms(1)])
  thus ?thesis by simp
qed

lemma dickson_grading_minus:
  assumes "dickson_grading d" and "s adds (t::'a::cancel_ab_semigroup_add)"
  shows "d (t - s)  d t"
proof -
  from assms(2) obtain u where "t = s + u" ..
  hence "t - s = u" by simp
  from assms(1) have "d t = ord_class.max (d s) (d u)" unfolding t = s + u by (rule dickson_gradingD1)
  thus ?thesis by (simp add: t - s = u)
qed

lemma dickson_grading_lcs:
  assumes "dickson_grading d"
  shows "d (lcs s t)  max (d s) (d t)"
proof -
  from assms have "d (lcs s t)  d (s + t)" by (rule dickson_grading_adds_imp_le, intro lcs_adds_plus)
  thus ?thesis by (simp only: dickson_gradingD1[OF assms])
qed

lemma dickson_grading_lcs_minus:
  assumes "dickson_grading d"
  shows "d (lcs s t - s)  max (d s) (d t)"
proof -
  from assms have "d (lcs s t - s)  d (lcs s t)" by (rule dickson_grading_minus, intro adds_lcs)
  also from assms have "...  max (d s) (d t)" by (rule dickson_grading_lcs)
  finally show ?thesis .
qed

lemma dgrad_set_leI:
  assumes "s. s  S  tT. d s  d t"
  shows "dgrad_set_le d S T"
  using assms by (auto simp: dgrad_set_le_def)

lemma dgrad_set_leE:
  assumes "dgrad_set_le d S T" and "s  S"
  obtains t where "t  T" and "d s  d t"
  using assms by (auto simp: dgrad_set_le_def)

lemma dgrad_set_exhaust_expl:
  assumes "finite F"
  shows "F  dgrad_set d (Max (d ` F))"
proof
  fix f
  assume "f  F"
  hence "d f  d ` F" by simp
  with _ have "d f  Max (d ` F)"
  proof (rule Max_ge)
    from assms show "finite (d ` F)" by auto
  qed
  hence "dgrad_set d (d f)  dgrad_set d (Max (d ` F))" by (auto simp: dgrad_set_def)
  moreover have "f  dgrad_set d (d f)" by (simp add: dgrad_set_def)
  ultimately show "f  dgrad_set d (Max (d ` F))" ..
qed

lemma dgrad_set_exhaust:
  assumes "finite F"
  obtains m where "F  dgrad_set d m"
proof
  from assms show "F  dgrad_set d (Max (d ` F))" by (rule dgrad_set_exhaust_expl)
qed

lemma dgrad_set_le_trans [trans]:
  assumes "dgrad_set_le d S T" and "dgrad_set_le d T U"
  shows "dgrad_set_le d S U"
  unfolding dgrad_set_le_def
proof
  fix s
  assume "s  S"
  with assms(1) obtain t where "t  T" and 1: "d s  d t" by (auto simp add: dgrad_set_le_def)
  from assms(2) this(1) obtain u where "u  U" and 2: "d t  d u" by (auto simp add: dgrad_set_le_def)
  from this(1) show "uU. d s  d u"
  proof
    from 1 2 show "d s  d u" by (rule le_trans)
  qed
qed

lemma dgrad_set_le_Un: "dgrad_set_le d (S  T) U  (dgrad_set_le d S U  dgrad_set_le d T U)"
  by (auto simp add: dgrad_set_le_def)

lemma dgrad_set_le_subset:
  assumes "S  T"
  shows "dgrad_set_le d S T"
  unfolding dgrad_set_le_def using assms by blast

lemma dgrad_set_le_refl: "dgrad_set_le d S S"
  by (rule dgrad_set_le_subset, fact subset_refl)

lemma dgrad_set_le_dgrad_set:
  assumes "dgrad_set_le d F G" and "G  dgrad_set d m"
  shows "F  dgrad_set d m"
proof
  fix f
  assume "f  F"
  with assms(1) obtain g where "g  G" and *: "d f  d g" by (auto simp add: dgrad_set_le_def)
  from assms(2) this(1) have "g  dgrad_set d m" ..
  hence "d g  m" by (simp add: dgrad_set_def)
  with * have "d f  m" by (rule le_trans)
  thus "f  dgrad_set d m" by (simp add: dgrad_set_def)
qed

lemma dgrad_set_dgrad: "p  dgrad_set d (d p)"
  by (simp add: dgrad_set_def)

lemma dgrad_setI [intro]:
  assumes "d t  m"
  shows "t  dgrad_set d m"
  using assms by (auto simp: dgrad_set_def)

lemma dgrad_setD:
  assumes "t  dgrad_set d m"
  shows "d t  m"
  using assms by (simp add: dgrad_set_def)

lemma dgrad_set_zero [simp]: "dgrad_set (λ_. 0) m = UNIV"
  by auto

lemma subset_dgrad_set_zero: "F  dgrad_set (λ_. 0) m"
  by simp

lemma dgrad_set_subset:
  assumes "m  n"
  shows "dgrad_set d m  dgrad_set d n"
  using assms by (auto simp: dgrad_set_def)

lemma dgrad_set_closed_plus:
  assumes "dickson_grading d" and "s  dgrad_set d m" and "t  dgrad_set d m"
  shows "s + t  dgrad_set d m"
proof -
  from assms(1) have "d (s + t) = ord_class.max (d s) (d t)" by (rule dickson_gradingD1)
  also from assms(2, 3) have "...  m" by (simp add: dgrad_set_def)
  finally show ?thesis by (simp add: dgrad_set_def)
qed

lemma dgrad_set_closed_minus:
  assumes "dickson_grading d" and "s  dgrad_set d m" and "t adds (s::'a::cancel_ab_semigroup_add)"
  shows "s - t  dgrad_set d m"
proof -
  from assms(1, 3) have "d (s - t)  d s" by (rule dickson_grading_minus)
  also from assms(2) have "...  m" by (simp add: dgrad_set_def)
  finally show ?thesis by (simp add: dgrad_set_def)
qed

lemma dgrad_set_closed_lcs:
  assumes "dickson_grading d" and "s  dgrad_set d m" and "t  dgrad_set d m"
  shows "lcs s t  dgrad_set d m"
proof -
  from assms(1) have "d (lcs s t)  ord_class.max (d s) (d t)" by (rule dickson_grading_lcs)
  also from assms(2, 3) have "...  m" by (simp add: dgrad_set_def)
  finally show ?thesis by (simp add: dgrad_set_def)
qed

lemma dickson_gradingD_dgrad_set: "dickson_grading d  almost_full_on (adds) (dgrad_set d m)"
  by (auto dest: dickson_gradingD2 simp: dgrad_set_def)

lemma ex_finite_adds:
  assumes "dickson_grading d" and "S  dgrad_set d m"
  obtains T where "finite T" and "T  S" and "s. s  S  (tT. t adds (s::'a::cancel_comm_monoid_add))"
proof -
  have "reflp ((adds)::'a  _)" by (simp add: reflp_def)
  moreover from assms(2) have "almost_full_on (adds) S"
  proof (rule almost_full_on_subset)
    from assms(1) show "almost_full_on (adds) (dgrad_set d m)" by (rule dickson_gradingD_dgrad_set)
  qed
  ultimately obtain T where "finite T" and "T  S" and "s. s  S  (tT. t adds s)"
    by (rule almost_full_on_finite_subsetE, blast)
  thus ?thesis ..
qed

class graded_dickson_powerprod = ulcs_powerprod +
  assumes ex_dgrad: "d::'a  nat. dickson_grading d"
begin

definition dgrad_dummy where "dgrad_dummy = (SOME d. dickson_grading d)"

lemma dickson_grading_dgrad_dummy: "dickson_grading dgrad_dummy"
  unfolding dgrad_dummy_def using ex_dgrad by (rule someI_ex)

end (* graded_dickson_powerprod *)

class dickson_powerprod = ulcs_powerprod +
  assumes dickson: "almost_full_on (adds) UNIV"
begin

lemma dickson_grading_zero: "dickson_grading (λ_::'a. 0)"
  by (simp add: dickson_grading_def dickson)

subclass graded_dickson_powerprod by (standard, rule, fact dickson_grading_zero)

end (* dickson_powerprod *)

text ‹Class @{class graded_dickson_powerprod} is a slightly artificial construction. It is needed,
  because type @{typ "nat 0 nat"} does not satisfy the usual conditions of a "Dickson domain" (as
  formulated in class @{class dickson_powerprod}), but we still want to use that type as the type of
  power-products in the computation of Gr\"obner bases. So, we exploit the fact that in a finite
  set of polynomials (which is the input of Buchberger's algorithm) there is always some "highest"
  indeterminate that occurs with non-zero exponent, and no "higher" indeterminates are generated
  during the execution of the algorithm. This allows us to prove that the algorithm terminates, even
  though there are in principle infinitely many indeterminates.›

subsection ‹Additive Linear Orderings›
  
lemma group_eq_aux: "a + (b - a) = (b::'a::ab_group_add)"
proof -
  have "a + (b - a) = b - a + a" by simp
  also have "... = b" by simp
  finally show ?thesis .
qed

class semi_canonically_ordered_monoid_add = ordered_comm_monoid_add +
  assumes le_imp_add: "a  b  (c. b = a + c)"

context canonically_ordered_monoid_add
begin
subclass semi_canonically_ordered_monoid_add
  by (standard, simp only: le_iff_add)
end

class add_linorder_group = ordered_ab_semigroup_add_imp_le + ab_group_add + linorder

class add_linorder = ordered_ab_semigroup_add_imp_le + cancel_comm_monoid_add + semi_canonically_ordered_monoid_add + linorder
begin

subclass ordered_comm_monoid_add ..

subclass ordered_cancel_comm_monoid_add ..

lemma le_imp_inv:
  assumes "a  b"
  shows "b = a + (b - a)"
  using le_imp_add[OF assms] by auto

lemma max_eq_sum:
  obtains y where "max a b = a + y"
  unfolding max_def
proof (cases "a  b")
  case True
  hence "b = a + (b - a)" by (rule le_imp_inv)
  then obtain c where eq: "b = a + c" ..
  show ?thesis
  proof
    from True show "max a b = a + c" unfolding max_def eq by simp
  qed
next
  case False
  show ?thesis
  proof
    from False show "max a b = a + 0" unfolding max_def by simp
  qed
qed
  
lemma min_plus_max:
  shows "(min a b) + (max a b) = a + b"
proof (cases "a  b")
  case True
  thus ?thesis unfolding min_def max_def by simp
next
  case False
  thus ?thesis unfolding min_def max_def by (simp add: ac_simps)
qed

end (* add_linorder *)

class add_linorder_min = add_linorder +
  assumes zero_min: "0  x"
begin

subclass ninv_comm_monoid_add
proof
  fix x y
  assume *: "x + y = 0"
  show "x = 0"
  proof -
    from zero_min[of x] have "0 = x  x > 0" by auto
    thus ?thesis
    proof
      assume "x > 0"
      have "0  y" by (fact zero_min)
      also have "... = 0 + y" by simp
      also from x > 0 have "... < x + y" by (rule add_strict_right_mono)
      finally have "0 < x + y" .
      hence "x + y  0" by simp
      from this * show ?thesis ..
    qed simp
  qed
qed
  
lemma leq_add_right:
  shows "x  x + y"
  using add_left_mono[OF zero_min[of y], of x] by simp

lemma leq_add_left:
  shows "x  y + x"
  using add_right_mono[OF zero_min[of y], of x] by simp

subclass canonically_ordered_monoid_add
  by (standard, rule, elim le_imp_add, elim exE, simp add: leq_add_right)

end (* add_linorder_min *)
  
class add_wellorder = add_linorder_min + wellorder
  
instantiation nat :: add_linorder
begin

instance by (standard, simp)

end (* add_linorder *)
  
instantiation nat :: add_linorder_min
begin
instance by (standard, simp)
end
  
instantiation nat :: add_wellorder
begin
instance ..
end
  
context add_linorder_group
begin
  
subclass add_linorder
proof (standard, intro exI)
  fix a b
  show "b = a + (b - a)" using add_commute local.diff_add_cancel by auto
qed

end (* add_linorder_group *)
  
instantiation int :: add_linorder_group
begin
instance ..
end

instantiation rat :: add_linorder_group
begin
instance ..
end

instantiation real :: add_linorder_group
begin
instance ..
end

subsection ‹Ordered Power-Products›

locale ordered_powerprod =
  ordered_powerprod_lin: linorder ord ord_strict
  for ord::"'a  'a::comm_powerprod  bool" (infixl "" 50)
  and ord_strict::"'a  'a::comm_powerprod  bool" (infixl "" 50) +
  assumes zero_min: "0  t"
  assumes plus_monotone: "s  t  s + u  t + u"
begin

abbreviation ord_conv (infixl "" 50) where "ord_conv  (≼)¯¯"
abbreviation ord_strict_conv (infixl "" 50) where "ord_strict_conv  (≺)¯¯"

lemma ord_canc:
  assumes "s + u  t + u"
  shows "s  t"
proof (rule ordered_powerprod_lin.le_cases[of s t], simp)
  assume "t  s"
  from assms plus_monotone[OF this, of u] have "t + u = s + u"
    using ordered_powerprod_lin.order.eq_iff by simp
  hence "t = s" by simp
  thus "s  t" by simp
qed

lemma ord_adds:
  assumes "s adds t"
  shows "s  t"
proof -
  from assms have "u. t = s + u" unfolding adds_def by simp
  then obtain k where "t = s + k" ..
  thus ?thesis using plus_monotone[OF zero_min[of k], of s] by (simp add: ac_simps)
qed

lemma ord_canc_left:
  assumes "u + s  u + t"
  shows "s  t"
  using assms unfolding add.commute[of u] by (rule ord_canc)

lemma ord_strict_canc:
  assumes "s + u  t + u"
  shows "s  t"
  using assms ord_canc[of s u t] add_right_cancel[of s u t]
    ordered_powerprod_lin.le_imp_less_or_eq ordered_powerprod_lin.order.strict_implies_order by blast

lemma ord_strict_canc_left:
  assumes "u + s  u + t"
  shows "s  t"
  using assms unfolding add.commute[of u] by (rule ord_strict_canc)

lemma plus_monotone_left:
  assumes "s  t"
  shows "u + s  u + t"
  using assms
  by (simp add: add.commute, rule plus_monotone)

lemma plus_monotone_strict:
  assumes "s  t"
  shows "s + u  t + u"
  using assms
  by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone)

lemma plus_monotone_strict_left:
  assumes "s  t"
  shows "u + s  u + t"
  using assms
  by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone_left)

end

locale gd_powerprod =
  ordered_powerprod ord ord_strict
  for ord::"'a  'a::graded_dickson_powerprod  bool" (infixl "" 50)
  and ord_strict (infixl "" 50)
begin

definition dickson_le :: "('a  nat)  nat  'a  'a  bool"
  where "dickson_le d m s t  (d s  m  d t  m  s  t)"

definition dickson_less :: "('a  nat)  nat  'a  'a  bool"
  where "dickson_less d m s t  (d s  m  d t  m  s  t)"

lemma dickson_leI:
  assumes "d s  m" and "d t  m" and "s  t"
  shows "dickson_le d m s t"
  using assms by (simp add: dickson_le_def)

lemma dickson_leD1:
  assumes "dickson_le d m s t"
  shows "d s  m"
  using assms by (simp add: dickson_le_def)

lemma dickson_leD2:
  assumes "dickson_le d m s t"
  shows "d t  m"
  using assms by (simp add: dickson_le_def)

lemma dickson_leD3:
  assumes "dickson_le d m s t"
  shows "s  t"
  using assms by (simp add: dickson_le_def)

lemma dickson_le_trans:
  assumes "dickson_le d m s t" and "dickson_le d m t u"
  shows "dickson_le d m s u"
  using assms by (auto simp add: dickson_le_def)

lemma dickson_lessI:
  assumes "d s  m" and "d t  m" and "s  t"
  shows "dickson_less d m s t"
  using assms by (simp add: dickson_less_def)

lemma dickson_lessD1:
  assumes "dickson_less d m s t"
  shows "d s  m"
  using assms by (simp add: dickson_less_def)

lemma dickson_lessD2:
  assumes "dickson_less d m s t"
  shows "d t  m"
  using assms by (simp add: dickson_less_def)

lemma dickson_lessD3:
  assumes "dickson_less d m s t"
  shows "s  t"
  using assms by (simp add: dickson_less_def)

lemma dickson_less_irrefl: "¬ dickson_less d m t t"
  by (simp add: dickson_less_def)

lemma dickson_less_trans:
  assumes "dickson_less d m s t" and "dickson_less d m t u"
  shows "dickson_less d m s u"
  using assms by (auto simp add: dickson_less_def)

lemma transp_dickson_less: "transp (dickson_less d m)"
  by (rule transpI, fact dickson_less_trans)

lemma wfp_on_ord_strict:
  assumes "dickson_grading d"
  shows "wfp_on (≺) {x. d x  n}"
proof -
  let ?A = "{x. d x  n}"
  have "strict (≼) = (≺)" by (intro ext, simp only: ordered_powerprod_lin.less_le_not_le)
  have "qo_on (adds) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def dest: adds_trans)
  moreover from assms have "wqo_on (adds) ?A" by (rule dickson_gradingD2')
  ultimately have "(Q. (x?A. y?A. x adds y  Q x y)  qo_on Q ?A  wfp_on (strict Q) ?A)"
    by (simp only: wqo_extensions_wf_conv)
  hence "(x?A. y?A. x adds y  x  y)  qo_on (≼) ?A  wfp_on (strict (≼)) ?A" ..
  thus ?thesis unfolding ‹strict (≼) = (≺)
  proof
    show "(x?A. y?A. x adds y  x  y)  qo_on (≼) ?A"
    proof (intro conjI ballI impI ord_adds)
      show "qo_on (≼) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
    qed
  qed
qed

lemma wf_dickson_less:
  assumes "dickson_grading d"
  shows "wfP (dickson_less d m)"
proof (rule wfP_chain)
  show "¬ (seq. i. dickson_less d m (seq (Suc i)) (seq i))"
  proof
    assume "seq. i. dickson_less d m (seq (Suc i)) (seq i)"
    then obtain seq::"nat  'a" where "i. dickson_less d m (seq (Suc i)) (seq i)" ..
    hence *: "i. dickson_less d m (seq (Suc i)) (seq i)" ..
    with transp_dickson_less have seq_decr: "i j. i < j  dickson_less d m (seq j) (seq i)"
      by (rule transp_sequence)

    from assms obtain i j where "i < j" and i_adds_j: "seq i adds seq j"
    proof (rule dickson_gradingE)
      fix i
      from * show "d (seq i)  m" by (rule dickson_lessD2)
    qed
    from i < j have "dickson_less d m (seq j) (seq i)" by (rule seq_decr)
    hence "seq j  seq i" by (rule dickson_lessD3)
    moreover from i_adds_j have "seq i  seq j" by (rule ord_adds)
    ultimately show False by simp
  qed
qed

end

text gd_powerprod› stands for @{emph ‹graded ordered Dickson power-products›}.›

locale od_powerprod =
  ordered_powerprod ord ord_strict
  for ord::"'a  'a::dickson_powerprod  bool" (infixl "" 50)
  and ord_strict (infixl "" 50)
begin

sublocale gd_powerprod by standard

lemma wf_ord_strict: "wfP (≺)"
proof (rule wfP_chain)
  show "¬ (seq. i. seq (Suc i)  seq i)"
  proof
    assume "seq. i. seq (Suc i)  seq i"
    then obtain seq::"nat  'a" where "i. seq (Suc i)  seq i" ..
    hence "i. seq (Suc i)  seq i" ..
    with ordered_powerprod_lin.transp_less have seq_decr: "i j. i < j  (seq j)  (seq i)"
      by (rule transp_sequence)

    from dickson obtain i j::nat where "i < j" and i_adds_j: "seq i adds seq j"
      by (auto elim!: almost_full_onD)
    from seq_decr[OF i < j] have "seq j  seq i  seq j  seq i" by auto
    hence "seq j  seq i" and "seq j  seq i" by simp_all
    from seq j  seq i seq j  seq i ord_adds[OF i_adds_j]
         ordered_powerprod_lin.order.eq_iff[of "seq j" "seq i"]
      show False by simp
  qed
qed

end

text od_powerprod› stands for @{emph ‹ordered Dickson power-products›}.›

subsection ‹Functions as Power-Products›

lemma finite_neq_0:
  assumes fin_A: "finite {x. f x  0}" and fin_B: "finite {x. g x  0}" and "x. h x 0 0 = 0"
  shows "finite {x. h x (f x) (g x)  0}"
proof -
  from fin_A fin_B have  "finite ({x. f x  0}  {x. g x  0})" by (intro finite_UnI)
  hence finite_union: "finite {x. (f x  0)  (g x  0)}" by (simp only: Collect_disj_eq)
  have "{x. h x (f x) (g x)  0}  {x. (f x  0)  (g x  0)}"
  proof (intro Collect_mono, rule)
    fix x::'a
    assume h_not_zero: "h x (f x) (g x)  0"
    have "f x = 0  g x  0"
    proof
      assume "f x = 0" "g x = 0"
      thus False using h_not_zero h x 0 0 = 0  by simp
    qed
    thus "f x  0  g x  0" by auto
  qed
  from finite_subset[OF this] finite_union show "finite {x. h x (f x) (g x)  0}" .
qed

lemma finite_neq_0':
  assumes "finite {x. f x  0}" and "finite {x. g x  0}" and "h 0 0 = 0"
  shows "finite {x. h (f x) (g x)  0}"
  using assms by (rule finite_neq_0)

lemma finite_neq_0_inv:
  assumes fin_A: "finite {x. h x (f x) (g x)  0}" and fin_B: "finite {x. f x  0}" and "x y. h x 0 y = y"
  shows "finite {x. g x  0}"
proof -
  from fin_A and fin_B have "finite ({x. h x (f x) (g x)  0}  {x. f x  0})" by (intro finite_UnI)
  hence finite_union: "finite {x. (h x (f x) (g x)  0)  f x  0}" by (simp only: Collect_disj_eq)
  have "{x. g x  0}  {x. (h x (f x) (g x)  0)  f x  0}"
    by (intro Collect_mono, rule, rule disjCI, simp add: assms(3))
  from this finite_union show "finite {x. g x  0}" by (rule finite_subset)
qed

lemma finite_neq_0_inv':
  assumes inf_A: "finite {x. h (f x) (g x)  0}" and fin_B: "finite {x. f x  0}" and "x. h 0 x = x"
  shows "finite {x. g x  0}"
  using assms by (rule finite_neq_0_inv)

subsubsection @{typ "'a  'b"} belongs to class @{class comm_powerprod}

instance "fun" :: (type, cancel_comm_monoid_add) comm_powerprod
  by standard

subsubsection @{typ "'a  'b"} belongs to class @{class ninv_comm_monoid_add}

instance "fun" :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
  by (standard, simp only: plus_fun_def zero_fun_def fun_eq_iff, intro allI, rule plus_eq_zero, auto)

subsubsection @{typ "'a  'b"} belongs to class @{class lcs_powerprod}

instantiation "fun" :: (type, add_linorder) lcs_powerprod
begin

definition lcs_fun::"('a  'b)  ('a  'b)  ('a  'b)" where "lcs f g = (λx. max (f x) (g x))"

lemma adds_funI:
  assumes "s  t"
  shows "s adds (t::'a  'b)"
proof (rule addsI, rule)
  fix x
  from assms have "s x  t x" unfolding le_fun_def ..
  hence "t x = s x + (t x - s x)" by (rule le_imp_inv)
  thus "t x = (s + (t - s)) x" by simp
qed

lemma adds_fun_iff: "f adds (g::'a  'b)  (x. f x adds g x)"
  unfolding adds_def plus_fun_def by metis

lemma adds_fun_iff': "f adds (g::'a  'b)  (x. y. g x = f x + y)"
  unfolding adds_fun_iff unfolding adds_def plus_fun_def ..

lemma adds_lcs_fun:
  shows "s adds (lcs s (t::'a  'b))"
  by (rule adds_funI, simp only: le_fun_def lcs_fun_def, auto simp: max_def)

lemma lcs_comm_fun:  "lcs s t = lcs t (s::'a  'b)"
  unfolding lcs_fun_def
  by (auto simp: max_def intro!: ext)

lemma lcs_adds_fun:
  assumes "s adds u" and "t adds (u::'a  'b)"
  shows "(lcs s t) adds u"
  using assms unfolding lcs_fun_def adds_fun_iff'
proof -
  assume a1: "x. y. u x = s x + y" and a2: "x. y. u x = t x + y"
  show "x. y. u x = max (s x) (t x) + y"
  proof
    fix x
    from a1 have b1: "y. u x = s x + y" ..
    from a2 have b2: "y. u x = t x + y" ..
    show "y. u x = max (s x) (t x) + y" unfolding max_def
      by (split if_split, intro conjI impI, rule b2, rule b1)
  qed
qed

instance
  apply standard
  subgoal by (rule adds_lcs_fun)
  subgoal by (rule lcs_adds_fun)
  subgoal by (rule lcs_comm_fun)
  done

end

lemma leq_lcs_fun_1: "s  (lcs s (t::'a  'b::add_linorder))"
  by (simp add: lcs_fun_def le_fun_def)

lemma leq_lcs_fun_2: "t  (lcs s (t::'a  'b::add_linorder))"
  by (simp add: lcs_fun_def le_fun_def)

lemma lcs_leq_fun:
  assumes "s  u" and "t  (u::'a  'b::add_linorder)"
  shows "(lcs s t)  u"
  using assms by (simp add: lcs_fun_def le_fun_def)

lemma adds_fun: "s adds t  s  t"
  for s t::"'a  'b::add_linorder_min"
proof
  assume "s adds t"
  from this obtain k where "t = s + k" ..
  show "s  t" unfolding t = s + k le_fun_def plus_fun_def le_iff_add by (simp add: leq_add_right)
qed (rule adds_funI)

lemma gcs_fun: "gcs s (t::'a  ('b::add_linorder)) = (λx. min (s x) (t x))"
proof -
  show ?thesis unfolding gcs_def lcs_fun_def fun_diff_def
  proof (simp, rule)
    fix x
    have eq: "s x + t x = max (s x) (t x) + min (s x) (t x)" by (metis add.commute min_def max_def)
    thus "s x + t x - max (s x) (t x) = min (s x) (t x)" by simp
  qed
qed

lemma gcs_leq_fun_1: "(gcs s (t::'a  'b::add_linorder))  s"
  by (simp add: gcs_fun le_fun_def)

lemma gcs_leq_fun_2: "(gcs s (t::'a  'b::add_linorder))  t"
  by (simp add: gcs_fun le_fun_def)

lemma leq_gcs_fun:
  assumes "u  s" and "u  (t::'a  'b::add_linorder)"
  shows "u  (gcs s t)"
  using assms by (simp add: gcs_fun le_fun_def)

subsubsection @{typ "'a  'b"} belongs to class @{class ulcs_powerprod}

instance "fun" :: (type, add_linorder_min) ulcs_powerprod ..

subsubsection ‹Power-products in a given set of indeterminates›

definition supp_fun::"('a  'b::zero)  'a set" where "supp_fun f = {x. f x  0}"

text @{term supp_fun} for general functions is like @{term keys} for @{type poly_mapping},
  but does not need to be finite.›

lemma keys_eq_supp: "keys s = supp_fun (lookup s)"
  unfolding supp_fun_def by (transfer, rule)

lemma supp_fun_zero [simp]: "supp_fun 0 = {}"
  by (auto simp: supp_fun_def)

lemma supp_fun_eq_zero_iff: "supp_fun f = {}  f = 0"
  by (auto simp: supp_fun_def)

lemma sub_supp_empty: "supp_fun s  {}  (s = 0)"
  by (auto simp: supp_fun_def)

lemma except_fun_idI: "supp_fun f  V = {}  except_fun f V = f"
  by (auto simp: except_fun_def supp_fun_def when_def intro!: ext)

lemma supp_except_fun: "supp_fun (except_fun s V) = supp_fun s - V"
  by (auto simp: except_fun_def supp_fun_def)

lemma supp_fun_plus_subset: "supp_fun (s + t)  supp_fun s  supp_fun (t::'a  'b::monoid_add)"
  unfolding supp_fun_def by force

lemma fun_eq_zeroI:
  assumes "x. x  supp_fun f  f x = 0"
  shows "f = 0"
proof (rule, simp)
  fix x
  show "f x = 0"
  proof (cases "x  supp_fun f")
    case True
    then show ?thesis by (rule assms)
  next
    case False
    then show ?thesis by (simp add: supp_fun_def)
  qed
qed

lemma except_fun_cong1:
  "supp_fun s  ((V - U)  (U - V))  {}  except_fun s V = except_fun s U"
  by (auto simp: except_fun_def when_def supp_fun_def intro!: ext)

lemma adds_except_fun:
  "s adds t = (except_fun s V adds except_fun t V  except_fun s (- V) adds except_fun t (- V))"
  for s t :: "'a  'b::add_linorder"
  by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)

lemma adds_except_fun_singleton: "s adds t = (except_fun s {v} adds except_fun t {v}  s v adds t v)"
  for s t :: "'a  'b::add_linorder"
  by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)

subsubsection ‹Dickson's lemma for power-products in finitely many indeterminates›

lemma Dickson_fun:
  assumes "finite V"
  shows "almost_full_on (adds) {x::'a  'b::add_wellorder. supp_fun x  V}"
  using assms
proof (induct V)
  case empty
  have "finite {0}" by simp
  moreover have "reflp_on (adds) {0::'a  'b}" by (simp add: reflp_on_def)
  ultimately have "almost_full_on (adds) {0::'a  'b}" by (rule finite_almost_full_on)
  thus ?case by (simp add: supp_fun_eq_zero_iff)
next
  case (insert v V)
  show ?case
  proof (rule almost_full_onI)
    fix seq::"nat  'a  'b"
    assume "i. seq i  {x. supp_fun x  insert v V}"
    hence a: "supp_fun (seq i)  insert v V" for i by simp
    define seq' where "seq' = (λi. (except_fun (seq i) {v}, except_fun (seq i) V))"
    have "almost_full_on (adds) {x::'a  'b. supp_fun x  {v}}"
    proof (rule almost_full_onI)
      fix f::"nat  'a  'b"
      assume "i. f i  {x. supp_fun x  {v}}"
      hence b: "supp_fun (f i)  {v}" for i by simp
      let ?f = "λi. f i v"
      have "wfP ((<)::'b  _)" by (simp add: wf wfP_def)
      hence "f::nat  'b. i. f i  f (Suc i)"
        by (simp add: wf_iff_no_infinite_down_chain[to_pred] not_less)
      hence "i. ?f i  ?f (Suc i)" ..
      then obtain i where "?f i  ?f (Suc i)" ..
      have "i < Suc i" by simp
      moreover have "f i adds f (Suc i)" unfolding adds_fun_iff
      proof
        fix x
        show "f i x adds f (Suc i) x"
        proof (cases "x = v")
          case True
          with ?f i  ?f (Suc i) show ?thesis by (simp add: adds_def le_iff_add)
        next
          case False
          with b have "x  supp_fun (f i)" and "x  supp_fun (f (Suc i))" by blast+
          thus ?thesis by (simp add: supp_fun_def)
        qed
      qed
      ultimately show "good (adds) f" by (meson goodI)
    qed
    with insert(3) have
      "almost_full_on (prod_le (adds) (adds)) ({x::'a  'b. supp_fun x  V} × {x::'a  'b. supp_fun x  {v}})"
      (is "almost_full_on ?P ?A") by (rule almost_full_on_Sigma)
    moreover from a have "seq' i  ?A" for i by (auto simp add: seq'_def supp_except_fun)
    ultimately obtain i j where "i < j" and "?P (seq' i) (seq' j)" by (rule almost_full_onD)
    have "seq i adds seq j" unfolding adds_except_fun[where s="seq i" and V=V]
    proof
      from ?P (seq' i) (seq' j) show "except_fun (seq i) V adds except_fun (seq j) V"
        by (simp add: prod_le_def seq'_def)
    next
      from ?P (seq' i) (seq' j) have "except_fun (seq i) {v} adds except_fun (seq j) {v}"
        by (simp add: prod_le_def seq'_def)
      moreover have "except_fun (seq i) (- V) = except_fun (seq i) {v}"
        by (rule except_fun_cong1; use a[of i] insert.hyps(2) in blast)
      moreover have "except_fun (seq j) (- V) = except_fun (seq j) {v}"
        by (rule except_fun_cong1; use a[of j] insert.hyps(2) in blast)
      ultimately show "except_fun (seq i) (- V) adds except_fun (seq j) (- V)" by simp
    qed
    with i < j show "good (adds) seq" by (meson goodI)
  qed
qed

instance "fun" :: (finite, add_wellorder) dickson_powerprod
proof
  have "finite (UNIV::'a set)" by simp
  hence "almost_full_on (adds) {x::'a  'b. supp_fun x  UNIV}" by (rule Dickson_fun)
  thus "almost_full_on (adds) (UNIV::('a  'b) set)" by simp
qed

subsubsection ‹Lexicographic Term Order›

text ‹Term orders are certain linear orders on power-products, satisfying additional requirements.
  Further information on term orders can be found, e.\,g., in @{cite Robbiano1985}.›

context wellorder
begin

lemma neq_fun_alt:
  assumes "s  (t::'a  'b)"
  obtains x where "s x  t x" and "y. s y  t y  x  y"
proof -
  from assms ext[of s t] have "x. s x  t x" by auto
  with exists_least_iff[of "λx. s x  t x"]
  obtain x where x1: "s x  t x" and x2: "y. y < x  s y = t y"
    by auto
  show ?thesis
  proof
    from x1 show "s x  t x" .
  next
    fix y
    assume "s y  t y"
    with x2[of y] have "¬ y < x" by auto
    thus "x  y" by simp
  qed
qed

definition lex_fun::"('a  'b)  ('a  'b::order)  bool" where
  "lex_fun s t  (x. s x  t x  (y<x. s y  t y))"

definition "lex_fun_strict s t  lex_fun s t  ¬ lex_fun t s"

text ‹Attention! @{term lex_fun} reverses the order of the indeterminates: if @{term x} is smaller than
  @{term y} w.r.t. the order on @{typ 'a}, then the @{emph ‹power-product›} @{term x} is
  @{emph ‹greater›} than the @{emph ‹power-product›} @{term y}.›

lemma lex_fun_alt:
  shows "lex_fun s t = (s = t  (x. s x < t x  (y<x. s y = t y)))" (is "?L = ?R")
proof
  assume ?L
  show ?R
  proof (cases "s = t")
    assume "s = t"
    thus ?R by simp
  next
    assume "s  t"
    from neq_fun_alt[OF this] obtain x0
      where x0_neq: "s x0  t x0" and x0_min: "z. s z  t z  x0  z" by auto
    show ?R
    proof (intro disjI2, rule exI[of _ x0], intro conjI)
      from ?L have "s x0  t x0  (y. y < x0  s y  t y)" unfolding lex_fun_def ..
      thus "s x0 < t x0"
      proof
        assume "s x0  t x0"
        from this x0_neq show ?thesis by simp
      next
        assume "y. y < x0  s y  t y"
        then obtain y where "y < x0" and y_neq: "s y  t y" by auto
        from y < x0 x0_min[OF y_neq] show ?thesis by simp
      qed
    next
      show "y<x0. s y = t y"
      proof (rule, rule)
        fix y
        assume "y < x0"
        hence "¬ x0  y" by simp
        from this x0_min[of y] show "s y = t y" by auto
      qed
    qed
  qed
next
  assume ?R
  thus ?L
  proof
    assume "s = t"
    thus ?thesis by (simp add: lex_fun_def)
  next
    assume "x. s x < t x  (y<x. s y = t y)"
    then obtain y where y: "s y < t y" and y_min: "z<y. s z = t z" by auto
    show ?thesis unfolding lex_fun_def
    proof
      fix x
      show "s x  t x  (y<x. s y  t y)"
      proof (cases "s x  t x")
        assume "s x  t x"
        thus ?thesis by simp
      next
        assume x: "¬ s x  t x"
        show ?thesis
        proof (intro disjI2, rule exI[of _ y], intro conjI)
          have "¬ x  y"
          proof
            assume "x  y"
            hence "x < y  y = x" by auto
            thus False
            proof
              assume "x < y"
              from x y_min[rule_format, OF this] show ?thesis by simp
            next
              assume "y = x"
              from this x y show ?thesis
                by (auto simp: preorder_class.less_le_not_le)
            qed
          qed
          thus "y < x" by simp
        next
          from y show "s y  t y" by simp
        qed
      qed
    qed
  qed
qed

lemma lex_fun_refl: "lex_fun s s"
unfolding lex_fun_alt by simp

lemma lex_fun_antisym:
  assumes "lex_fun s t" and "lex_fun t s"
  shows "s = t"
proof
  fix x
  from assms(1) have "s = t  (x. s x < t x  (y<x. s y = t y))"
    unfolding lex_fun_alt .
  thus "s x = t x"
  proof
    assume "s = t"
    thus ?thesis by simp
  next
    assume "x. s x < t x  (y<x. s y = t y)"
    then obtain x0 where x0: "s x0 < t x0" and x0_min: "y<x0. s y = t y" by auto
    from assms(2) have "t = s  (x. t x < s x  (y<x. t y = s y))" unfolding lex_fun_alt .
    thus ?thesis
    proof
      assume "t = s"
      thus ?thesis by simp
    next
      assume "x. t x < s x  (y<x. t y = s y)"
      then obtain x1 where x1: "t x1 < s x1" and x1_min: "y<x1. t y = s y" by auto
      have "x0 < x1  x1 < x0  x1 = x0" using local.antisym_conv3 by auto
      show ?thesis
      proof (rule linorder_cases[of x0 x1])
        assume "x1 < x0"
        from x0_min[rule_format, OF this] x1 show ?thesis by simp
      next
        assume "x0 = x1"
        from this x0 x1 show ?thesis by simp
      next
        assume "x0 < x1"
        from x1_min[rule_format, OF this] x0 show ?thesis by simp
      qed
    qed
  qed
qed

lemma lex_fun_trans:
  assumes "lex_fun s t" and "lex_fun t u"
  shows "lex_fun s u"
proof -
  from assms(1) have "s = t  (x. s x < t x  (y<x. s y = t y))" unfolding lex_fun_alt .
  thus ?thesis
  proof
    assume "s = t"
    from this assms(2) show ?thesis by simp
  next
    assume "x. s x < t x  (y<x. s y = t y)"
    then obtain x0 where x0: "s x0 < t x0" and x0_min: "y<x0. s y = t y"
      by auto
    from assms(2) have "t = u  (x. t x < u x  (y<x. t y = u y))" unfolding lex_fun_alt .
    thus ?thesis
    proof
      assume "t = u"
      from this assms(1) show ?thesis by simp
    next
      assume "x. t x < u x  (y<x. t y = u y)"
      then obtain x1 where x1: "t x1 < u x1" and x1_min: "y<x1. t y = u y" by auto
      show ?thesis unfolding lex_fun_alt
      proof (intro disjI2)
        show "x. s x < u x  (y<x. s y = u y)"
        proof (rule linorder_cases[of x0 x1])
          assume "x1 < x0"
          show ?thesis
          proof (rule exI[of _ x1], intro conjI)
            from x0_min[rule_format, OF x1 < x0] x1 show "s x1 < u x1" by simp
          next
            show "y<x1. s y = u y"
            proof (intro allI, intro impI)
              fix y
              assume "y < x1"
              from this x1 < x0 have "y < x0" by simp
              from x0_min[rule_format, OF this] x1_min[rule_format, OF y < x1]
                show "s y = u y" by simp
            qed
          qed
        next
          assume "x0 < x1"
          show ?thesis
          proof (rule exI[of _ x0], intro conjI)
            from x1_min[rule_format, OF x0 < x1] x0 show "s x0 < u x0" by simp
          next
            show "y<x0. s y = u y"
            proof (intro allI, intro impI)
              fix y
              assume "y < x0"
              from this x0 < x1 have "y < x1" by simp
              from x0_min[rule_format, OF y < x0] x1_min[rule_format, OF this]
                show "s y = u y" by simp
            qed
          qed
        next
          assume "x0 = x1"
          show ?thesis
          proof (rule exI[of _ x1], intro conjI)
            from x0 = x1 x0 x1 show "s x1 < u x1" by simp
          next
            show "y<x1. s y = u y"
            proof (intro allI, intro impI)
              fix y
              assume "y < x1"
              hence "y < x0" using x0 = x1 by simp
              from x0_min[rule_format, OF this] x1_min[rule_format, OF y < x1]
                show "s y = u y" by simp
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma lex_fun_lin: "lex_fun s t  lex_fun t s" for s t::"'a  'b::{ordered_comm_monoid_add, linorder}"
proof (intro disjCI)
  assume "¬ lex_fun t s"
  hence a: "x. ¬ (t x < s x)  (y<x. t y  s y)" unfolding lex_fun_alt by auto
  show "lex_fun s t" unfolding lex_fun_def
  proof
    fix x
    from a have "¬ (t x < s x)  (y<x. t y  s y)" ..
    thus "s x  t x  (y<x. s y  t y)" by auto
  qed
qed

corollary lex_fun_strict_alt [code]:
  "lex_fun_strict s t = (¬ lex_fun t s)" for s t::"'a  'b::{ordered_comm_monoid_add, linorder}"
  unfolding lex_fun_strict_def using lex_fun_lin[of s t] by auto

lemma lex_fun_zero_min: "lex_fun 0 s" for s::"'a  'b::add_linorder_min"
  by (simp add: lex_fun_def zero_min)

lemma lex_fun_plus_monotone:
  "lex_fun (s + u) (t + u)" if "lex_fun s t"
  for s t::"'a  'b::ordered_cancel_comm_monoid_add"
unfolding lex_fun_def
proof
  fix x
  from that have "s x  t x  (y<x. s y  t y)" unfolding lex_fun_def ..
  thus "(s + u) x  (t + u) x  (y<x. (s + u) y  (t + u) y)"
  proof
    assume a1: "s x  t x"
    show ?thesis
    proof (intro disjI1)
      from a1 show "(s + u) x  (t + u) x" by (auto simp: add_right_mono)
    qed
  next
    assume "y<x. s y  t y"
    then obtain y where "y < x" and a2: "s y  t y" by auto
    show ?thesis
    proof (intro disjI2, rule exI[of _ y], intro conjI, fact)
      from a2 show "(s + u) y  (t + u) y" by (auto simp: add_right_mono)
    qed
  qed
qed

end (* wellorder *)

subsubsection ‹Degree›

definition deg_fun::"('a  'b::comm_monoid_add)  'b" where "deg_fun s  x(supp_fun s). s x"

lemma deg_fun_zero[simp]: "deg_fun 0 = 0"
  by (auto simp: deg_fun_def)

lemma deg_fun_eq_0_iff:
  assumes "finite (supp_fun (s::'a  'b::add_linorder_min))"
  shows "deg_fun s = 0  s = 0"
proof
  assume "deg_fun s = 0"
  hence *: "(x(supp_fun s). s x) = 0" by (simp only: deg_fun_def)
  have **: "x. 0  s x" by (rule zero_min)
  from * have "x. x  supp_fun s  s x = 0" by (simp only: sum_nonneg_eq_0_iff[OF assms **])
  thus "s = 0" by (rule fun_eq_zeroI)
qed simp

lemma deg_fun_superset:
  fixes A::"'a set"
  assumes "supp_fun s  A" and "finite A"
  shows "deg_fun s = (xA. s x)"
  unfolding deg_fun_def
proof (rule sum.mono_neutral_cong_left, fact, fact, rule)
  fix x
  assume "x  A - supp_fun s"
  hence "x  supp_fun s" by simp
  thus "s x = 0" by (simp add: supp_fun_def)
qed rule

lemma deg_fun_plus:
  assumes "finite (supp_fun s)" and "finite (supp_fun t)"
  shows "deg_fun (s + t) = deg_fun s + deg_fun (t::'a  'b::comm_monoid_add)"
proof -
  from assms have fin: "finite (supp_fun s  supp_fun t)" by simp
  have "deg_fun (s + t) = (x(supp_fun (s + t)). s x + t x)" by (simp add: deg_fun_def)
  also from fin have "... = (x(supp_fun s  supp_fun t). s x + t x)"
  proof (rule sum.mono_neutral_cong_left)
    show "xsupp_fun s  supp_fun t - supp_fun (s + t). s x + t x = 0"
    proof
      fix x
      assume "x  supp_fun s  supp_fun t - supp_fun (s + t)"
      hence "x  supp_fun (s + t)" by simp
      thus "s x + t x = 0" by (simp add: supp_fun_def)
    qed
  qed (rule supp_fun_plus_subset, rule)
  also have " = (x(supp_fun s  supp_fun t). s x) + (x(supp_fun s  supp_fun t). t x)"
    by (rule sum.distrib)
  also from fin have "(x(supp_fun s  supp_fun t). s x) = deg_fun s" unfolding deg_fun_def
  proof (rule sum.mono_neutral_cong_right)
    show "xsupp_fun s  supp_fun t - supp_fun s. s x = 0"
    proof
      fix x
      assume "x  supp_fun s  supp_fun t - supp_fun s"
      hence "x  supp_fun s" by simp
      thus "s x = 0" by (simp add: supp_fun_def)
    qed
  qed simp_all
  also from fin have "(x(supp_fun s  supp_fun t). t x) = deg_fun t" unfolding deg_fun_def
  proof (rule sum.mono_neutral_cong_right)
  show "xsupp_fun s  supp_fun t - supp_fun t. t x = 0"
    proof
      fix x
      assume "x  supp_fun s  supp_fun t - supp_fun t"
      hence "x  supp_fun t" by simp
      thus "t x = 0" by (simp add: supp_fun_def)
    qed
  qed simp_all
  finally show ?thesis .
qed

lemma deg_fun_leq:
  assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "s  (t::'a  'b::ordered_comm_monoid_add)"
  shows "deg_fun s  deg_fun t"
proof -
  let ?A = "supp_fun s  supp_fun t"
  from assms(1) assms(2) have 1: "finite ?A" by simp
  have s: "supp_fun s  ?A" and t: "supp_fun t  ?A" by simp_all
  show ?thesis unfolding deg_fun_superset[OF s 1] deg_fun_superset[OF t 1]
  proof (rule sum_mono)
    fix i
    from assms(3) show "s i  t i" unfolding le_fun_def ..
  qed
qed

subsubsection ‹General Degree-Orders›

context linorder
begin

lemma ex_min:
  assumes "finite (A::'a set)" and "A  {}"
  shows "yA. (zA. y  z)"
using assms
proof (induct rule: finite_induct)
  assume "{}  {}"
  thus "y{}. z{}. y  z" by simp
next
  fix a::'a and A::"'a set"
  assume "a  A" and IH: "A  {}  yA. (zA. y  z)"
  show "yinsert a A. (zinsert a A. y  z)"
  proof (cases "A = {}")
    case True
    show ?thesis
    proof (rule bexI[of _ a], intro ballI)
      fix z
      assume "z  insert a A"
      from this True have "z = a" by simp
      thus "a  z" by simp
    qed (simp)
  next
    case False
    from IH[OF False] obtain y where "y  A" and y_min: "zA. y  z" by auto
    from linear[of a y] show ?thesis
    proof
      assume "y  a"
      show ?thesis
      proof (rule bexI[of _ y], intro ballI)
        fix z
        assume "z  insert a A"
        hence "z = a  z  A" by simp
        thus "y  z"
        proof
          assume "z = a"
          from this y  a show "y  z" by simp
        next
          assume "z  A"
          from y_min[rule_format, OF this] show "y  z" .
        qed
      next
        from y  A show "y  insert a A" by simp
      qed
    next
      assume "a  y"
      show ?thesis
      proof (rule bexI[of _ a], intro ballI)
        fix z
        assume "z  insert a A"
        hence "z = a  z  A" by simp
        thus "a  z"
        proof
          assume "z = a"
          from this show "a  z" by simp
        next
          assume "z  A"
          from y_min[rule_format, OF this] a  y show "a  z" by simp
        qed
      qed (simp)
    qed
  qed
qed

definition dord_fun::"(('a  'b::ordered_comm_monoid_add)  ('a  'b)  bool)  ('a  'b)  ('a  'b)  bool"
  where "dord_fun ord s t  (let d1 = deg_fun s; d2 = deg_fun t in (d1 < d2  (d1 = d2  ord s t)))"

lemma dord_fun_degD:
  assumes "dord_fun ord s t"
  shows "deg_fun s  deg_fun t"
  using assms unfolding dord_fun_def Let_def by auto

lemma dord_fun_refl:
  assumes "ord s s"
  shows "dord_fun ord s s"
  using assms unfolding dord_fun_def by simp

lemma dord_fun_antisym:
  assumes ord_antisym: "ord s t  ord t s  s = t" and "dord_fun ord s t" and "dord_fun ord t s"
  shows "s = t"
proof -
  from assms(3) have ts: "deg_fun t < deg_fun s  (deg_fun t = deg_fun s  ord t s)"
    unfolding dord_fun_def Let_def .
  from assms(2) have st: "deg_fun s < deg_fun t  (deg_fun s = deg_fun t  ord s t)"
    unfolding dord_fun_def Let_def .
  thus ?thesis
  proof
    assume "deg_fun s < deg_fun t"
    thus ?thesis using ts by auto
  next
    assume "deg_fun s = deg_fun t  ord s t"
    hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
    from ‹deg_fun s = deg_fun t ts have "ord t s" by simp
    with ord s t show ?thesis by (rule ord_antisym)
  qed
qed

lemma dord_fun_trans:
  assumes ord_trans: "ord s t  ord t u  ord s u" and "dord_fun ord s t" and "dord_fun ord t u"
  shows "dord_fun ord s u"
proof -
  from assms(3) have ts: "deg_fun t < deg_fun u  (deg_fun t = deg_fun u  ord t u)"
    unfolding dord_fun_def Let_def .
  from assms(2) have st: "deg_fun s < deg_fun t  (deg_fun s = deg_fun t  ord s t)"
    unfolding dord_fun_def Let_def .
  thus ?thesis
  proof
    assume "deg_fun s < deg_fun t"
    from this dord_fun_degD[OF assms(3)] have "deg_fun s < deg_fun u" by simp
    thus ?thesis by (simp add: dord_fun_def Let_def)
  next
    assume "deg_fun s = deg_fun t  ord s t"
    hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
    from ts show ?thesis
    proof
      assume "deg_fun t < deg_fun u"
      hence "deg_fun s < deg_fun u" using ‹deg_fun s = deg_fun t by simp
      thus ?thesis by (simp add: dord_fun_def Let_def)
    next
      assume "deg_fun t = deg_fun u  ord t u"
      hence "deg_fun t = deg_fun u" and "ord t u" by simp_all
      from ord_trans[OF ord s t ord t u] ‹deg_fun s = deg_fun t ‹deg_fun t = deg_fun u show ?thesis
        by (simp add: dord_fun_def Let_def)
    qed
  qed
qed

lemma dord_fun_lin:
  "dord_fun ord s t  dord_fun ord t s"
  if "ord s t  ord t s"
  for s t::"'a  'b::{ordered_comm_monoid_add, linorder}"
proof (intro disjCI)
  assume "¬ dord_fun ord t s"
  hence "deg_fun s  deg_fun t  (deg_fun t  deg_fun s  ¬ ord t s)"
    unfolding dord_fun_def Let_def by auto
  hence "deg_fun s  deg_fun t" and dis1: "deg_fun t  deg_fun s  ¬ ord t s" by simp_all
  show "dord_fun ord s t" unfolding dord_fun_def Let_def
  proof (intro disjCI)
    assume "¬ (deg_fun s = deg_fun t  ord s t)"
    hence dis2: "deg_fun s  deg_fun t  ¬ ord s t" by simp
    show "deg_fun s < deg_fun t"
    proof (cases "deg_fun s = deg_fun t")
      case True
      from True dis1 have "¬ ord t s" by simp
      from True dis2 have "¬ ord s t" by simp
      from ¬ ord s t ¬ ord t s that show ?thesis by simp
    next
      case False
      from this ‹deg_fun s  deg_fun t show ?thesis by simp
    qed
  qed
qed

lemma dord_fun_zero_min:
  fixes s t::"'a  'b::add_linorder_min"
  assumes ord_refl: "t. ord t t" and "finite (supp_fun s)"
  shows "dord_fun ord 0 s"
  unfolding dord_fun_def Let_def deg_fun_zero
proof (rule disjCI)
  assume "¬ (0 = deg_fun s  ord 0 s)"
  hence dis: "deg_fun s  0  ¬ ord 0 s" by simp
  show "0 < deg_fun s"
  proof (cases "deg_fun s = 0")
    case True
    hence "s = 0" using deg_fun_eq_0_iff[OF assms(2)] by auto
    hence "ord 0 s" using ord_refl by simp
    with True dis show ?thesis by simp
  next
    case False
    thus ?thesis by (auto simp: zero_less_iff_neq_zero)
  qed
qed

lemma dord_fun_plus_monotone:
  fixes s t u ::"'a  'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
  assumes ord_monotone: "ord s t  ord (s + u) (t + u)" and "finite (supp_fun s)"
    and "finite (supp_fun t)" and "finite (supp_fun u)" and "dord_fun ord s t"
  shows "dord_fun ord (s + u) (t + u)"
proof -
  from assms(5) have "deg_fun s < deg_fun t  (deg_fun s = deg_fun t  ord s t)"
    unfolding dord_fun_def Let_def .
  thus ?thesis
  proof
    assume "deg_fun s < deg_fun t"
    hence "deg_fun (s + u) < deg_fun (t + u)" by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
    thus ?thesis unfolding dord_fun_def Let_def by simp
  next
    assume "deg_fun s = deg_fun t  ord s t"
    hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
    from ‹deg_fun s = deg_fun t have "deg_fun (s + u) = deg_fun (t + u)"
      by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
    from this ord_monotone[OF ord s t] show ?thesis unfolding dord_fun_def Let_def by simp
  qed
qed

end (* linorder *)

context wellorder
begin

subsubsection ‹Degree-Lexicographic Term Order›

definition dlex_fun::"('a  'b::ordered_comm_monoid_add)  ('a  'b)  bool"
  where "dlex_fun  dord_fun lex_fun"

definition "dlex_fun_strict s t  dlex_fun s t  ¬ dlex_fun t s"

lemma dlex_fun_refl:
  shows "dlex_fun s s"
unfolding dlex_fun_def by (rule dord_fun_refl, rule lex_fun_refl)

lemma dlex_fun_antisym:
  assumes "dlex_fun s t" and "dlex_fun t s"
  shows "s = t"
  by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
      simp_all only: dlex_fun_def[symmetric], fact+)

lemma dlex_fun_trans:
  assumes "dlex_fun s t" and "dlex_fun t u"
  shows "dlex_fun s u"
  by (simp only: dlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
      simp_all only: dlex_fun_def[symmetric], fact+)

lemma dlex_fun_lin: "dlex_fun s t  dlex_fun t s"
  for s t::"('a  'b::{ordered_comm_monoid_add, linorder})"
  unfolding dlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)

corollary dlex_fun_strict_alt [code]:
  "dlex_fun_strict s t = (¬ dlex_fun t s)" for s t::"'a  'b::{ordered_comm_monoid_add, linorder}"
  unfolding dlex_fun_strict_def using dlex_fun_lin by auto

lemma dlex_fun_zero_min:
  fixes s t::"('a  'b::add_linorder_min)"
  assumes "finite (supp_fun s)"
  shows "dlex_fun 0 s"
  unfolding dlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)

lemma dlex_fun_plus_monotone:
  fixes s t u::"'a  'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
  assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "dlex_fun s t"
  shows "dlex_fun (s + u) (t + u)"
  using lex_fun_plus_monotone[of s t u] assms unfolding dlex_fun_def
  by (rule dord_fun_plus_monotone)

subsubsection ‹Degree-Reverse-Lexicographic Term Order›

abbreviation rlex_fun::"('a  'b)  ('a  'b::order)  bool" where
  "rlex_fun s t  lex_fun t s"

text ‹Note that @{const rlex_fun} is not precisely the reverse-lexicographic order relation on
  power-products. Normally, the @{emph ‹last›} (i.\,e. highest) indeterminate whose exponent differs
  in the two power-products to be compared is taken, but since we do not require the domain to be finite,
  there might not be such a last indeterminate. Therefore, we simply take the converse of
  @{const lex_fun}.›

definition drlex_fun::"('a  'b::ordered_comm_monoid_add)  ('a  'b)  bool"
  where "drlex_fun  dord_fun rlex_fun"

definition "drlex_fun_strict s t  drlex_fun s t  ¬ drlex_fun t s"

lemma drlex_fun_refl:
  shows "drlex_fun s s"
  unfolding drlex_fun_def by (rule dord_fun_refl, fact lex_fun_refl)

lemma drlex_fun_antisym:
  assumes "drlex_fun s t" and "drlex_fun t s"
  shows "s = t"
  by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
      simp_all only: drlex_fun_def[symmetric], fact+)

lemma drlex_fun_trans:
  assumes "drlex_fun s t" and "drlex_fun t u"
  shows "drlex_fun s u"
  by (simp only: drlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
      simp_all only: drlex_fun_def[symmetric], fact+)

lemma drlex_fun_lin: "drlex_fun s t  drlex_fun t s"
  for s t::"('a  'b::{ordered_comm_monoid_add, linorder})"
  unfolding drlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)

corollary drlex_fun_strict_alt [code]:
  "drlex_fun_strict s t = (¬ drlex_fun t s)" for s t::"'a  'b::{ordered_comm_monoid_add, linorder}"
  unfolding drlex_fun_strict_def using drlex_fun_lin by auto

lemma drlex_fun_zero_min:
  fixes s t::"('a  'b::add_linorder_min)"
  assumes "finite (supp_fun s)"
  shows "drlex_fun 0 s"
  unfolding drlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)

lemma drlex_fun_plus_monotone:
  fixes s t u::"'a  'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
  assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "drlex_fun s t"
  shows "drlex_fun (s + u) (t + u)"
  using lex_fun_plus_monotone[of t s u] assms unfolding drlex_fun_def
  by (rule dord_fun_plus_monotone)

end (* wellorder *)

text‹Every finite linear ordering is also a well-ordering. This fact is particularly useful when
  working with fixed finite sets of indeterminates.›
class finite_linorder = finite + linorder
begin

subclass wellorder
proof
  fix P::"'a  bool" and a
  assume hyp: "x. (y. (y < x)  P y)  P x"
  show "P a"
  proof (rule ccontr)
    assume "¬ P a"
    have "finite {x. ¬ P x}" (is "finite ?A") by simp
    from ¬ P a have "a  ?A" by simp
    hence "?A  {}" by auto
    from ex_min[OF ‹finite ?A this] obtain b where "b  ?A" and b_min: "y?A. b  y" by auto
    from b  ?A have "¬ P b" by simp
    with hyp[of b] obtain y where "y < b" and "¬ P y" by auto
    from ¬ P y have "y  ?A" by simp
    with b_min have "b  y" by simp
    with y < b show False by simp
  qed
qed

end


subsection ‹Type @{type poly_mapping}

lemma poly_mapping_eq_zeroI:
  assumes "keys s = {}"
  shows "s = (0::('a, 'b::zero) poly_mapping)"
proof (rule poly_mapping_eqI, simp)
  fix x
  from assms show "lookup s x = 0" by auto
qed

lemma keys_plus_ninv_comm_monoid_add: "keys (s + t) = keys s  keys (t::'a 0 'b::ninv_comm_monoid_add)"
proof (rule, fact Poly_Mapping.keys_add, rule)
  fix x
  assume "x  keys s  keys t"
  thus "x  keys (s + t)"
  proof
    assume "x  keys s"
    thus ?thesis
      by (metis in_keys_iff lookup_add plus_eq_zero)
  next
    assume "x  keys t"
    thus ?thesis
      by (metis in_keys_iff lookup_add plus_eq_zero_2)
  qed
qed

lemma lookup_zero_fun: "lookup 0 = 0"
  by (simp only: zero_poly_mapping.rep_eq zero_fun_def)

lemma lookup_plus_fun: "lookup (s + t) = lookup s + lookup t"
  by (simp only: plus_poly_mapping.rep_eq plus_fun_def)

lemma lookup_uminus_fun: "lookup (- s) = - lookup s"
  by (fact uminus_poly_mapping.rep_eq)

lemma lookup_minus_fun: "lookup (s - t) = lookup s - lookup t"
  by (simp only: minus_poly_mapping.rep_eq, rule, simp only: minus_apply)

lemma poly_mapping_adds_iff: "s adds t  lookup s adds lookup t"
  unfolding adds_def
proof
  assume "k. t = s + k"
  then obtain k where *: "t = s + k" ..
  show "k. lookup t = lookup s + k"
  proof
    from * show "lookup t = lookup s + lookup k" by (simp only: lookup_plus_fun)
  qed
next
  assume "k. lookup t = lookup s + k"
  then obtain k where *: "lookup t = lookup s + k" ..
  have **: "k  {f. finite {x. f x  0}}"
  proof
    have "finite {x. lookup t x  0}" by transfer
    hence "finite {x. lookup s x + k x  0}" by (simp only: * plus_fun_def)
    moreover have "finite {x. lookup s x  0}" by transfer
    ultimately show "finite {x. k x  0}" by (rule finite_neq_0_inv', simp)
  qed
  show "k. t = s + k"
  proof
    show "t = s + Abs_poly_mapping k"
      by (rule poly_mapping_eqI, simp add: * lookup_add Abs_poly_mapping_inverse[OF **])
  qed
qed

subsubsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}

instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
  by standard

subsubsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}

instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
  fix s t::"'a  'b"
  assume "(λk. s k + t k) = (λ_. 0)"
  hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
  hence "s = 0" by (rule plus_eq_zero)
  thus "s = (λ_. 0)" by (simp only: zero_fun_def)
qed

subsubsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class lcs_powerprod}

instantiation poly_mapping :: (type, add_linorder) lcs_powerprod
begin

lift_definition lcs_poly_mapping::"('a 0 'b)  ('a 0 'b)  ('a 0 'b)" is "λs t. λx. max (s x) (t x)"
proof -
  fix fun1 fun2::"'a  'b"
  assume "finite {t. fun1 t  0}" and "finite {t. fun2 t  0}"
  from finite_neq_0'[OF this, of max] show "finite {t. max (fun1 t) (fun2 t)  0}"
    by (auto simp: max_def)
qed

lemma adds_poly_mappingI:
  assumes "lookup s  lookup (t::'a 0 'b)"
  shows "s adds t"
  unfolding poly_mapping_adds_iff using assms by (rule adds_funI)

lemma lookup_lcs_fun: "lookup (lcs s t) = lcs (lookup s) (lookup (t:: 'a 0 'b))"
  by (simp only: lcs_poly_mapping.rep_eq lcs_fun_def)

instance
  by (standard, simp_all only: poly_mapping_adds_iff lookup_lcs_fun, rule adds_lcs, elim lcs_adds,
      assumption, rule poly_mapping_eqI, simp only: lookup_lcs_fun lcs_comm)

end

lemma adds_poly_mapping: "s adds t  lookup s  lookup t"
  for s t::"'a 0 'b::add_linorder_min"
  by (simp only: poly_mapping_adds_iff adds_fun)

lemma lookup_gcs_fun: "lookup (gcs s (t::'a 0 ('b::add_linorder))) = gcs (lookup s) (lookup t)"
proof
  fix x
  show "lookup (gcs s t) x = gcs (lookup s) (lookup t) x"
    by (simp add: gcs_def lookup_minus lookup_add lookup_lcs_fun)
qed

subsubsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class ulcs_powerprod}

instance poly_mapping :: (type, add_linorder_min) ulcs_powerprod ..

subsubsection ‹Power-products in a given set of indeterminates.›

lemma adds_except:
  "s adds t = (except s V adds except t V  except s (- V) adds except t (- V))"
  for s t :: "'a 0 'b::add_linorder"
  by (simp add: poly_mapping_adds_iff adds_except_fun[of "lookup s", where V=V] except.rep_eq)

lemma adds_except_singleton:
  "s adds t  (except s {v} adds except t {v}  lookup s v adds lookup t v)"
  for s t :: "'a 0 'b::add_linorder"
  by (simp add: poly_mapping_adds_iff adds_except_fun_singleton[of "lookup s", where v=v] except.rep_eq)

subsubsection ‹Dickson's lemma for power-products in finitely many indeterminates›

context countable
begin

definition elem_index :: "'a  nat" where "elem_index = (SOME f. inj f)"

lemma inj_elem_index: "inj elem_index"
  unfolding elem_index_def using ex_inj by (rule someI_ex)

lemma elem_index_inj:
  assumes "elem_index x = elem_index y"
  shows "x = y"
  using inj_elem_index assms by (rule injD)

lemma finite_nat_seg: "finite {x. elem_index x < n}"
proof (rule finite_imageD)
  have "elem_index ` {x. elem_index x < n}  {0..<n}" by auto
  moreover have "finite ..." ..
  ultimately show "finite (elem_index ` {x. elem_index x < n})" by (rule finite_subset)
next
  from inj_elem_index show "inj_on elem_index {x. elem_index x < n}" using inj_on_subset by blast
qed

end (* countable *)

lemma Dickson_poly_mapping:
  assumes "finite V"
  shows "almost_full_on (adds) {x::'a 0 'b::add_wellorder. keys x  V}"
proof (rule almost_full_onI)
  fix seq::"nat  'a 0 'b"
  assume a: "i. seq i  {x::'a 0 'b. keys x  V}"
  define seq' where "seq' = (λi. lookup (seq i))"
  from assms have "almost_full_on (adds) {x::'a  'b. supp_fun x  V}" by (rule Dickson_fun)
  moreover from a have "i. seq' i  {x::'a  'b. supp_fun x  V}"
    by (auto simp: seq'_def keys_eq_supp)
  ultimately obtain i j where "i < j" and "seq' i adds seq' j" by (rule almost_full_onD)
  from this(2) have "seq i adds seq j" by (simp add: seq'_def poly_mapping_adds_iff)
  with i < j show "good (adds) seq" by (rule goodI)
qed

definition varnum :: "'x set  ('x::countable 0 'b::zero)  nat"
  where "varnum X t = (if keys t - X = {} then 0 else Suc (Max (elem_index ` (keys t - X))))"

lemma elem_index_less_varnum:
  assumes "x  keys t"
  obtains "x  X" | "elem_index x < varnum X t"
proof (cases "x  X")
  case True
  thus ?thesis ..
next
  case False
  with assms have 1: "x  keys t - X" by simp
  hence "keys t - X  {}" by blast
  hence eq: "varnum X t = Suc (Max (elem_index ` (keys t - X)))" by (simp add: varnum_def)
  hence "elem_index x < varnum X t" using 1 by (simp add: less_Suc_eq_le)
  thus ?thesis ..
qed

lemma varnum_plus:
  "varnum X (s + t) = max (varnum X s) (varnum X (t::'x::countable 0 'b::ninv_comm_monoid_add))"
proof (simp add: varnum_def keys_plus_ninv_comm_monoid_add image_Un Un_Diff del: Diff_eq_empty_iff, intro impI)
  assume 1: "keys s - X  {}" and 2: "keys t - X  {}"
  have "finite (elem_index ` (keys s - X))" by simp
  moreover from 1 have "elem_index ` (keys s - X)  {}" by simp
  moreover have "finite (elem_index ` (keys t - X))" by simp
  moreover from 2 have "elem_index ` (keys t - X)  {}" by simp
  ultimately show "Max (elem_index ` (keys s - X)  elem_index ` (keys t - X)) =
                    max (Max (elem_index ` (keys s - X))) (Max (elem_index ` (keys t - X)))"
    by (rule Max_Un)
qed

lemma dickson_grading_varnum:
  assumes "finite X"
  shows "dickson_grading ((varnum X)::('x::countable 0 'b::add_wellorder)  nat)"
  using varnum_plus
proof (rule dickson_gradingI)
  fix m::nat
  let ?V = "X  {x. elem_index x < m}"
  have "{t::'x 0 'b. varnum X t  m}  {t. keys t  ?V}"
  proof (rule, simp, intro subsetI, simp)
    fix t::"'x 0 'b" and x::'x
    assume "varnum X t  m"
    assume "x  keys t"
    thus "x  X  elem_index x < m"
    proof (rule elem_index_less_varnum)
      assume "x  X"
      thus ?thesis ..
    next
      assume "elem_index x < varnum X t"
      hence "elem_index x < m" using ‹varnum X t  m by (rule less_le_trans)
      thus ?thesis ..
    qed
  qed
  thus "almost_full_on (adds) {t::'x 0 'b. varnum X t  m}"
  proof (rule almost_full_on_subset)
    from assms finite_nat_seg have "finite ?V" by (rule finite_UnI)
    thus "almost_full_on (adds) {t::'x 0 'b. keys t  ?V}" by (rule Dickson_poly_mapping)
  qed
qed

corollary dickson_grading_varnum_empty:
  "dickson_grading ((varnum {})::(_ 0 _::add_wellorder)  nat)"
  using finite.emptyI by (rule dickson_grading_varnum)

lemma varnum_le_iff: "varnum X t  n  keys t  X  {x. elem_index x < n}"
  by (auto simp: varnum_def Suc_le_eq)

lemma varnum_zero [simp]: "varnum X 0 = 0"
  by (simp add: varnum_def)

lemma varnum_empty_eq_zero_iff: "varnum {} t = 0  t = 0"
proof
  assume "varnum {} t = 0"
  hence "keys t = {}" by (simp add: varnum_def split: if_splits)
  thus "t = 0" by (rule poly_mapping_eq_zeroI)
qed simp

instance poly_mapping :: (countable, add_wellorder) graded_dickson_powerprod
  by standard (rule, fact dickson_grading_varnum_empty)

instance poly_mapping :: (finite, add_wellorder) dickson_powerprod
proof
  have "finite (UNIV::'a set)" by simp
  hence "almost_full_on (adds) {x::'a 0 'b. keys x  UNIV}" by (rule Dickson_poly_mapping)
  thus "almost_full_on (adds) (UNIV::('a 0 'b) set)" by simp
qed

subsubsection ‹Lexicographic Term Order›

definition lex_pm :: "('a 0 'b)  ('a::linorder 0 'b::{zero,linorder})  bool"
  where "lex_pm = (≤)"

definition lex_pm_strict :: "('a 0 'b)  ('a::linorder 0 'b::{zero,linorder})  bool"
  where "lex_pm_strict = (<)"

lemma lex_pm_alt: "lex_pm s t = (s = t  (x. lookup s x < lookup t x  (y<x. lookup s y = lookup t y)))"
  unfolding lex_pm_def by (metis less_eq_poly_mapping.rep_eq less_funE less_funI poly_mapping_eq_iff)

lemma lex_pm_refl: "lex_pm s s"
  by (simp add: lex_pm_def)

lemma lex_pm_antisym: "lex_pm s t  lex_pm t s  s = t"
  by (simp add: lex_pm_def)

lemma lex_pm_trans: "lex_pm s t  lex_pm t u  lex_pm s u"
  by (simp add: lex_pm_def)

lemma lex_pm_lin: "lex_pm s t  lex_pm t s"
  by (simp add: lex_pm_def linear)

corollary lex_pm_strict_alt [code]: "lex_pm_strict s t = (¬ lex_pm t s)"
  by (auto simp: lex_pm_strict_def lex_pm_def)

lemma lex_pm_zero_min: "lex_pm 0 s" for s::"_ 0 _::add_linorder_min"
proof (rule ccontr)
  assume "¬ lex_pm 0 s"
  hence "lex_pm_strict s 0" by (simp add: lex_pm_strict_alt)
  thus False by (simp add: lex_pm_strict_def less_poly_mapping.rep_eq less_fun_def)
qed

lemma lex_pm_plus_monotone: "lex_pm s t  lex_pm (s + u) (t + u)"
  for s t::"_ 0 _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
  by (simp add: lex_pm_def add_right_mono)

subsubsection ‹Degree›

lift_definition deg_pm::"('a 0 'b::comm_monoid_add)  'b" is deg_fun .

lemma deg_pm_zero[simp]: "deg_pm 0 = 0"
  by (simp add: deg_pm.rep_eq lookup_zero_fun)

lemma deg_pm_eq_0_iff[simp]: "deg_pm s = 0  s = 0" for s::"'a 0 'b::add_linorder_min"
  by (simp only: deg_pm.rep_eq poly_mapping_eq_iff lookup_zero_fun, rule deg_fun_eq_0_iff,
      simp add: keys_eq_supp[symmetric])

lemma deg_pm_superset:
  assumes "keys s  A" and "finite A"
  shows "deg_pm s = (xA. lookup s x)"
  using assms by (simp only: deg_pm.rep_eq keys_eq_supp, elim deg_fun_superset)

lemma deg_pm_plus: "deg_pm (s + t) = deg_pm s + deg_pm (t::'a 0 'b::comm_monoid_add)"
  by (simp only: deg_pm.rep_eq lookup_plus_fun, rule deg_fun_plus, simp_all add: keys_eq_supp[symmetric])

lemma deg_pm_single: "deg_pm (Poly_Mapping.single x k) = k"
proof -
  have "keys (Poly_Mapping.single x k)  {x}" by simp
  moreover have "finite {x}" by simp
  ultimately have "deg_pm (Poly_Mapping.single x k) = (y{x}. lookup (Poly_Mapping.single x k) y)"
    by (rule deg_pm_superset)
  also have "... = k" by simp
  finally show ?thesis .
qed

subsubsection ‹General Degree-Orders›

context linorder
begin

lift_definition dord_pm::"(('a 0 'b::ordered_comm_monoid_add)  ('a 0 'b)  bool)  ('a 0 'b)  ('a 0 'b)  bool"
  is dord_fun by (metis local.dord_fun_def)

lemma dord_pm_alt: "dord_pm ord = (λx y. deg_pm x < deg_pm y  (deg_pm x = deg_pm y  ord x y))"
  by (intro ext) (transfer, simp add: dord_fun_def Let_def)

lemma dord_pm_degD:
  assumes "dord_pm ord s t"
  shows "deg_pm s  deg_pm t"
  using assms by (simp only: dord_pm.rep_eq deg_pm.rep_eq, elim dord_fun_degD)

lemma dord_pm_refl:
  assumes "ord s s"
  shows "dord_pm ord s s"
  using assms by (simp only: dord_pm.rep_eq, intro dord_fun_refl, simp add: lookup_inverse)

lemma dord_pm_antisym:
  assumes "ord s t  ord t s  s = t" and "dord_pm ord s t" and "dord_pm ord t s"
  shows "s = t"
  using assms
proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
  assume 1: "(ord s t  ord t s  lookup s = lookup t)"
  assume 2: "dord_fun (map_fun Abs_poly_mapping id  ord  Abs_poly_mapping) (lookup s) (lookup t)"
  assume 3: "dord_fun (map_fun Abs_poly_mapping id  ord  Abs_poly_mapping) (lookup t) (lookup s)"
  from _ 2 3 show "lookup s = lookup t" by (rule dord_fun_antisym, simp add: lookup_inverse 1)
qed

lemma dord_pm_trans:
  assumes "ord s t  ord t u  ord s u" and "dord_pm ord s t" and "dord_pm ord t u"
  shows "dord_pm ord s u"
  using assms
proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
  assume 1: "(ord s t  ord t u  ord s u)"
  assume 2: "dord_fun (map_fun Abs_poly_mapping id  ord  Abs_poly_mapping) (lookup s) (lookup t)"
  assume 3: "dord_fun (map_fun Abs_poly_mapping id  ord  Abs_poly_mapping) (lookup t) (lookup u)"
  from _ 2 3 show "dord_fun (map_fun Abs_poly_mapping id  ord  Abs_poly_mapping) (lookup s) (lookup u)"
    by (rule dord_fun_trans, simp add: lookup_inverse 1)
qed

lemma dord_pm_lin:
  "dord_pm ord s t  dord_pm ord t s"
  if "ord s t  ord t s"
  for s t::"'a 0 'b::{ordered_comm_monoid_add, linorder}"
  using that by (simp only: dord_pm.rep_eq, intro dord_fun_lin, simp add: lookup_inverse)

lemma dord_pm_zero_min: "dord_pm ord 0 s"
  if ord_refl: "t. ord t t"
  for s t::"'a 0 'b::add_linorder_min"
  using that
  by (simp only: dord_pm.rep_eq lookup_zero_fun, intro dord_fun_zero_min,
      simp add: lookup_inverse, simp add: keys_eq_supp[symmetric])

lemma dord_pm_plus_monotone:
  fixes s t u ::"'a 0 'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
  assumes "ord s t  ord (s + u) (t + u)" and "dord_pm ord s t"
  shows "dord_pm ord (s + u) (t + u)"
  using assms
  by (simp only: dord_pm.rep_eq lookup_plus_fun, intro dord_fun_plus_monotone,
      simp add: lookup_inverse lookup_plus_fun[symmetric],
      simp add: keys_eq_supp[symmetric],
      simp add: keys_eq_supp[symmetric],
      simp add: keys_eq_supp[symmetric],
      simp add: lookup_inverse)

end (* linorder *)

subsubsection ‹Degree-Lexicographic Term Order›

definition dlex_pm::"('a::linorder 0 'b::{ordered_comm_monoid_add,linorder})  ('a 0 'b)  bool"
  where "dlex_pm  dord_pm lex_pm"

definition "dlex_pm_strict s t  dlex_pm s t  ¬ dlex_pm t s"

lemma dlex_pm_refl: "dlex_pm s s"
  unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_refl)

lemma dlex_pm_antisym: "dlex_pm s t  dlex_pm t s  s = t"
  unfolding dlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)

lemma dlex_pm_trans: "dlex_pm s t  dlex_pm t u  dlex_pm s u"
  unfolding dlex_pm_def using lex_pm_trans by (rule dord_pm_trans)

lemma dlex_pm_lin: "dlex_pm s t  dlex_pm t s"
  unfolding dlex_pm_def using lex_pm_lin by (rule dord_pm_lin)

corollary dlex_pm_strict_alt [code]: "dlex_pm_strict s t = (¬ dlex_pm t s)"
  unfolding dlex_pm_strict_def using dlex_pm_lin by auto

lemma dlex_pm_zero_min: "dlex_pm 0 s"
  for s t::"(_ 0 _::add_linorder_min)"
  unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)

lemma dlex_pm_plus_monotone: "dlex_pm s t  dlex_pm (s + u) (t + u)"
  for s t::"_ 0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
  unfolding dlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)

subsubsection ‹Degree-Reverse-Lexicographic Term Order›

definition drlex_pm::"('a::linorder 0 'b::{ordered_comm_monoid_add,linorder})  ('a 0 'b)  bool"
  where "drlex_pm  dord_pm (λs t. lex_pm t s)"

definition "drlex_pm_strict s t  drlex_pm s t  ¬ drlex_pm t s"

lemma drlex_pm_refl: "drlex_pm s s"
  unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_refl)

lemma drlex_pm_antisym: "drlex_pm s t  drlex_pm t s  s = t"
  unfolding drlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)

lemma drlex_pm_trans: "drlex_pm s t  drlex_pm t u  drlex_pm s u"
  unfolding drlex_pm_def using lex_pm_trans by (rule dord_pm_trans)

lemma drlex_pm_lin: "drlex_pm s t  drlex_pm t s"
  unfolding drlex_pm_def using lex_pm_lin by (rule dord_pm_lin)

corollary drlex_pm_strict_alt [code]: "drlex_pm_strict s t = (¬ drlex_pm t s)"
  unfolding drlex_pm_strict_def using drlex_pm_lin by auto

lemma drlex_pm_zero_min: "drlex_pm 0 s"
  for s t::"(_ 0 _::add_linorder_min)"
  unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)

lemma drlex_pm_plus_monotone: "drlex_pm s t  drlex_pm (s + u) (t + u)"
  for s t::"_ 0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
  unfolding drlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)

end (* theory *)

Theory More_Modules

(* Author: Alexander Maletzky *)

theory More_Modules
  imports HOL.Modules
begin

text ‹More facts about modules.›

section ‹Modules over Commutative Rings›

context module
begin

lemma scale_minus_both [simp]: "(- a) *s (- x) = a *s x"
  by simp

subsection ‹Submodules Spanned by Sets of Module-Elements›

lemma span_insertI:
  assumes "p  span B"
  shows "p  span (insert r B)"
proof -
  have "B  insert r B" by blast
  hence "span B  span (insert r B)" by (rule span_mono)
  with assms show ?thesis ..
qed

lemma span_insertD:
  assumes "p  span (insert r B)" and "r  span B"
  shows "p  span B"
  using assms(1)
proof (induct p rule: span_induct_alt)
  case base
  show "0  span B" by (fact span_zero)
next
  case step: (step q b a)
  from step(1) have "b = r  b  B" by simp
  thus "q *s b + a  span B"
  proof
    assume eq: "b = r"
    from step(2) assms(2) show ?thesis unfolding eq by (intro span_add span_scale)
  next
    assume "b  B"
    hence "b  span B" using span_superset ..
    with step(2) show ?thesis by (intro span_add span_scale)
  qed
qed

lemma span_insert_idI:
  assumes "r  span B"
  shows "span (insert r B) = span B"
proof (intro subset_antisym subsetI)
  fix p
  assume "p  span (insert r B)"
  from this assms show "p  span B" by (rule span_insertD)
next
  fix p
  assume "p  span B"
  thus "p  span (insert r B)" by (rule span_insertI)
qed

lemma span_insert_zero: "span (insert 0 B) = span B"
  using span_zero by (rule span_insert_idI)

lemma span_Diff_zero: "span (B - {0}) = span B"
  by (metis span_insert_zero insert_Diff_single)

lemma span_insert_subset:
  assumes "span A  span B" and "r  span B"
  shows "span (insert r A)  span B"
proof
  fix p
  assume "p  span (insert r A)"
  thus "p  span B"
  proof (induct p rule: span_induct_alt)
    case base
    show ?case by (fact span_zero)
  next
    case step: (step q b a)
    show ?case
    proof (intro span_add span_scale)
      from b  insert r A show "b  span B"
      proof
        assume "b = r"
        thus "b  span B" using assms(2) by simp
      next
        assume "b  A"
        hence "b  span A" using span_superset ..
        thus "b  span B" using assms(1) ..
      qed
    qed fact
  qed
qed

lemma replace_span:
  assumes "q  span B"
  shows "span (insert q (B - {p}))  span B"
  by (rule span_insert_subset, rule span_mono, fact Diff_subset, fact)

lemma sum_in_spanI: "(bB. q b *s b)  span B"
  by (auto simp: intro: span_sum span_scale dest: span_base)

lemma span_closed_sum_list: "(x. x  set xs  x  span B)  sum_list xs  span B"
  by (induct xs) (auto intro: span_zero span_add)

lemma spanE:
  assumes "p  span B"
  obtains A q where "finite A" and "A  B" and "p = (bA. (q b) *s b)"
  using assms by (auto simp: span_explicit)

lemma span_finite_subset:
  assumes "p  span B"
  obtains A where "finite A" and "A  B" and "p  span A"
proof -
  from assms obtain A q where "finite A" and "A  B" and p: "p = (aA. q a *s a)"
    by (rule spanE)
  note this(1, 2)
  moreover have "p  span A" unfolding p by (rule sum_in_spanI)
  ultimately show ?thesis ..
qed

lemma span_finiteE:
  assumes "finite B" and "p  span B"
  obtains q where "p = (bB. (q b) *s b)"
  using assms by (auto simp: span_finite)

lemma span_subset_spanI:
  assumes "A  span B"
  shows "span A  span B"
  using assms subspace_span by (rule span_minimal)

lemma span_insert_cong:
  assumes "span A = span B"
  shows "span (insert p A) = span (insert p B)" (is "?l = ?r")
proof
  have 1: "span (insert p C1)  span (insert p C2)" if "span C1 = span C2" for C1 C2
  proof (rule span_subset_spanI)
    show "insert p C1  span (insert p C2)"
    proof (rule insert_subsetI)
      show "p  span (insert p C2)" by (rule span_base) simp
    next
      have "C1  span C1" by (rule span_superset)
      also from that have " = span C2" .
      also have "  span (insert p C2)" by (rule span_mono) blast
      finally show "C1  span (insert p C2)" .
    qed
  qed
  from assms show "?l  ?r" by (rule 1)
  from assms[symmetric] show "?r  ?l" by (rule 1)
qed

lemma span_induct' [consumes 1, case_names base step]:
  assumes "p  span B" and "P 0"
    and "a q p. a  span B  P a  p  B  q  0  P (a + q *s p)"
  shows "P p"
  using assms(1, 1)
proof (induct p rule: span_induct_alt)
  case base
  from assms(2) show ?case .
next
  case (step q b a)
  from step.hyps(1) have "b  span B" by (rule span_base)
  hence "q *s b  span B" by (rule span_scale)
  with step.prems have "a  span B" by (simp only: span_add_eq)
  hence "P a" by (rule step.hyps)
  show ?case
  proof (cases "q = 0")
    case True
    from P a show ?thesis by (simp add: True)
  next
    case False
    with a  span B P a step.hyps(1) have "P (a + q *s b)" by (rule assms(3))
    thus ?thesis by (simp only: add.commute)
  qed
qed

lemma span_INT_subset: "span (aA. f a)  (aA. span (f a))" (is "?l  ?r")
proof
  fix p
  assume "p  ?l"
  show "p  ?r"
  proof
    fix a
    assume "a  A"
    from p  ?l show "p  span (f a)"
    proof (induct p rule: span_induct')
      case base
      show ?case by (fact span_zero)
    next
      case (step p q b)
      from step(3) a  A have "b  f a" ..
      hence "b  span (f a)" by (rule span_base)
      with step(2) show ?case by (intro span_add span_scale)
    qed
  qed
qed

lemma span_INT: "span (aA. span (f a)) = (aA. span (f a))" (is "?l = ?r")
proof
  have "?l  (aA. span (span (f a)))" by (rule span_INT_subset)
  also have "... = ?r" by (simp add: span_span)
  finally show "?l  ?r" .
qed (fact span_superset)

lemma span_Int_subset: "span (A  B)  span A  span B"
proof -
  have "span (A  B) = span (x{A, B}. x)" by simp
  also have "  (x{A, B}. span x)" by (fact span_INT_subset)
  also have " = span A  span B" by simp
  finally show ?thesis .
qed

lemma span_Int: "span (span A  span B) = span A  span B"
proof -
  have "span (span A  span B) = span (x{A, B}. span x)" by simp
  also have " = (x{A, B}. span x)" by (fact span_INT)
  also have " = span A  span B" by simp
  finally show ?thesis .
qed

lemma span_image_scale_eq_image_scale: "span ((*s) q ` F) = (*s) q ` span F" (is "?A = ?B")
proof (intro subset_antisym subsetI)
  fix p
  assume "p  ?A"
  thus "p  ?B"
  proof (induct p rule: span_induct')
    case base
    from span_zero show ?case by (rule rev_image_eqI) simp
  next
    case (step p r a)
    from step.hyps(2) obtain p' where "p'  span F" and p: "p = q *s p'" ..
    from step.hyps(3) obtain a' where "a'  F" and a: "a = q *s a'" ..
    from this(1) have "a'  span F" by (rule span_base)
    hence "r *s a'  span F" by (rule span_scale)
    with p'  span F have "p' + r *s a'  span F" by (rule span_add)
    hence "q *s (p' + r *s a')  ?B" by (rule imageI)
    also have "q *s (p' + r *s a') = p + r *s a" by (simp add: a p algebra_simps)
    finally show ?case .
  qed
next
  fix p
  assume "p  ?B"
  then obtain p' where "p'  span F" and "p = q *s p'" ..
  from this(1) show "p  ?A" unfolding p = q *s p'
  proof (induct p' rule: span_induct')
    case base
    show ?case by (simp add: span_zero)
  next
    case (step p r a)
    from step.hyps(3) have "q *s a  (*s) q ` F" by (rule imageI)
    hence "q *s a  ?A" by (rule span_base)
    hence "r *s (q *s a)  ?A" by (rule span_scale)
    with step.hyps(2) have "q *s p + r *s (q *s a)  ?A" by (rule span_add)
    also have "q *s p + r *s (q *s a) = q *s (p + r *s a)" by (simp add: algebra_simps)
    finally show ?case .
  qed
qed

end (* module *)

section ‹Ideals over Commutative Rings›

lemma module_times: "module (*)"
  by (standard, simp_all add: algebra_simps)

interpretation ideal: module times
  by (fact module_times)

declare ideal.scale_scale[simp del]

abbreviation "ideal  ideal.span"

lemma ideal_eq_UNIV_iff_contains_one: "ideal B = UNIV  1  ideal B"
proof
  assume *: "1  ideal B"
  show "ideal B = UNIV"
  proof
    show "UNIV  ideal B"
    proof
      fix x
      from * have "x * 1  ideal B" by (rule ideal.span_scale)
      thus "x  ideal B" by simp
    qed
  qed simp
qed simp

lemma ideal_eq_zero_iff [iff]: "ideal F = {0}  F  {0}"
  by (metis empty_subsetI ideal.span_empty ideal.span_eq)

lemma ideal_field_cases:
  obtains "ideal B = {0}" | "ideal (B::'a::field set) = UNIV"
proof (cases "ideal B = {0}")
  case True
  thus ?thesis ..
next
  case False
  hence "¬ B  {0}" by simp
  then obtain b where "b  B" and "b  0" by blast
  from this(1) have "b  ideal B" by (rule ideal.span_base)
  hence "inverse b * b  ideal B" by (rule ideal.span_scale)
  with b  0 have "ideal B = UNIV" by (simp add: ideal_eq_UNIV_iff_contains_one)
  thus ?thesis ..
qed

corollary ideal_field_disj: "ideal B = {0}  ideal (B::'a::field set) = UNIV"
  by (rule ideal_field_cases) blast+

lemma image_ideal_subset:
  assumes "x y. h (x + y) = h x + h y" and "x y. h (x * y) = h x * h y"
  shows "h ` ideal F  ideal (h ` F)"
proof (intro subsetI, elim imageE)
  fix g f
  assume g: "g = h f"
  assume "f  ideal F"
  thus "g  ideal (h ` F)" unfolding g
  proof (induct f rule: ideal.span_induct_alt)
    case base
    have "h 0 = h (0 + 0)" by simp
    also have " = h 0 + h 0" by (simp only: assms(1))
    finally show ?case by (simp add: ideal.span_zero)
  next
    case (step c f g)
    from step.hyps(1) have "h f  ideal (h ` F)"
      by (intro ideal.span_base imageI)
    hence "h c * h f  ideal (h ` F)" by (rule ideal.span_scale)
    hence "h c * h f + h g  ideal (h ` F)"
      using step.hyps(2) by (rule ideal.span_add)
    thus ?case by (simp only: assms)
  qed
qed

lemma image_ideal_eq_surj:
  assumes "x y. h (x + y) = h x + h y" and "x y. h (x * y) = h x * h y" and "surj h"
  shows "h ` ideal B = ideal (h ` B)"
proof
  from assms(1, 2) show "h ` ideal B  ideal (h ` B)" by (rule image_ideal_subset)
next
  show "ideal (h ` B)  h ` ideal B"
  proof
    fix b
    assume "b  ideal (h ` B)"
    thus "b  h ` ideal B"
    proof (induct b rule: ideal.span_induct_alt)
      case base
      have "h 0 = h (0 + 0)" by simp
      also have " = h 0 + h 0" by (simp only: assms(1))
      finally have "0 = h 0" by simp
      with ideal.span_zero show ?case by (rule rev_image_eqI)
    next
      case (step c b a)
      from assms(3) obtain c' where c: "c = h c'" by (rule surjE)
      from step.hyps(2) obtain a' where "a'  ideal B" and a: "a = h a'" ..
      from step.hyps(1) obtain b' where "b'  B" and b: "b = h b'" ..
      from this(1) have "b'  ideal B" by (rule ideal.span_base)
      hence "c' * b'  ideal B" by (rule ideal.span_scale)
      hence "c' * b' + a'  ideal B" using a'  _ by (rule ideal.span_add)
      moreover have "c * b + a = h (c' * b' + a')"
        by (simp add: c b a assms(1, 2))
      ultimately show ?case by (rule rev_image_eqI)
    qed
  qed
qed

context
  fixes h :: "'a  'a::comm_ring_1"
  assumes h_plus: "h (x + y) = h x + h y"
  assumes h_times: "h (x * y) = h x * h y"
  assumes h_idem: "h (h x) = h x"
begin

lemma in_idealE_homomorphism_finite:
  assumes "finite B" and "B  range h" and "p  range h" and "p  ideal B"
  obtains q where "b. q b  range h" and "p = (bB. q b * b)"
proof -
  from assms(1, 4) obtain q0 where p: "p = (bB. q0 b * b)" by (rule ideal.span_finiteE)
  define q where "q = (λb. h (q0 b))"
  show ?thesis
  proof
    fix b
    show "q b  range h" unfolding q_def by (rule rangeI)
  next
    from assms(3) obtain p' where "p = h p'" ..
    hence "p = h p" by (simp only: h_idem)
    also from ‹finite B have " = (bB. q b * h b)" unfolding p
    proof (induct B)
      case empty
      have "h 0 = h (0 + 0)" by simp
      also have " = h 0 + h 0" by (simp only: h_plus)
      finally show ?case by simp
    next
      case (insert b B)
      thus ?case by (simp add: h_plus h_times q_def)
    qed
    also from refl have " = (bB. q b * b)"
    proof (rule sum.cong)
      fix b
      assume "b  B"
      hence "b  range h" using assms(2) ..
      then obtain b' where "b = h b'" ..
      thus "q b * h b = q b * b" by (simp only: h_idem)
    qed
    finally show "p = (bB. q b * b)" .
  qed
qed

corollary in_idealE_homomorphism:
  assumes "B  range h" and "p  range h" and "p  ideal B"
  obtains A q where "finite A" and "A  B" and "b. q b  range h" and "p = (bA. q b * b)"
proof -
  from assms(3) obtain A where "finite A" and "A  B" and "p  ideal A"
    by (rule ideal.span_finite_subset)
  from this(2) assms(1) have "A  range h" by (rule subset_trans)
  with ‹finite A obtain q where "b. q b  range h" and "p = (bA. q b * b)"
    using assms(2) p  ideal A by (rule in_idealE_homomorphism_finite) blast
  with ‹finite A A  B show ?thesis ..
qed

lemma ideal_induct_homomorphism [consumes 3, case_names 0 plus]:
  assumes "B  range h" and "p  range h" and "p  ideal B"
  assumes "P 0" and "c b a. c  range h  b  B  P a  a  range h  P (c * b + a)"
  shows "P p"
proof -
  from assms(1-3) obtain A q where "finite A" and "A  B" and rl: "f. q f  range h"
    and p: "p = (fA. q f * f)" by (rule in_idealE_homomorphism) blast
  show ?thesis unfolding p using ‹finite A A  B
  proof (induct A)
    case empty
    from assms(4) show ?case by simp
  next
    case (insert a A)
    from insert.hyps(1, 2) have "(finsert a A. q f * f) = q a * a + (fA. q f * f)" by simp
    also from rl have "P "
    proof (rule assms(5))
      have "a  insert a A" by simp
      thus "a  B" using insert.prems ..
    next
      from insert.prems have "A  B" by simp
      thus "P (fA. q f * f)" by (rule insert.hyps)
    next
      from insert.prems have "A  B" by simp
      hence "A  range h" using assms(1) by (rule subset_trans)
      with ‹finite A show "(fA. q f * f)  range h"
      proof (induct A)
        case empty
        have "h 0 = h (0 + 0)" by simp
        also have " = h 0 + h 0" by (simp only: h_plus)
        finally have "(f{}. q f * f) = h 0" by simp
        thus ?case by (rule image_eqI) simp
      next
        case (insert a A)
        from insert.prems have "a  range h" and "A  range h" by simp_all
        from this(1) obtain a' where a: "a = h a'" ..
        from q a  range h obtain q' where q: "q a = h q'" ..
        from A  _ have "(fA. q f * f)  range h" by (rule insert.hyps)
        then obtain m where eq: "(fA. q f * f) = h m" ..
        from insert.hyps(1, 2) have "(finsert a A. q f * f) = q a * a + (fA. q f * f)" by simp
        also have " = h (q' * a' + m)" unfolding q by (simp add: a eq h_plus h_times)
        also have "  range h" by (rule rangeI)
        finally show ?case .
      qed
    qed
    finally show ?case .
  qed
qed

lemma image_ideal_eq_Int: "h ` ideal B = ideal (h ` B)  range h"
proof
  from h_plus h_times have "h ` ideal B  ideal (h ` B)" by (rule image_ideal_subset)
  thus "h ` ideal B  ideal (h ` B)  range h" by blast
next
  show "ideal (h ` B)  range h  h ` ideal B"
  proof
    fix b
    assume "b  ideal (h ` B)  range h"
    hence "b  ideal (h ` B)" and "b  range h" by simp_all
    have "h ` B  range h" by blast
    thus "b  h ` ideal B" using b  range h b  ideal (h ` B)
    proof (induct b rule: ideal_induct_homomorphism)
      case 0
      have "h 0 = h (0 + 0)" by simp
      also have " = h 0 + h 0" by (simp only: h_plus)
      finally have "0 = h 0" by simp
      with ideal.span_zero show ?case by (rule rev_image_eqI)
    next
      case (plus c b a)
      from plus.hyps(1) obtain c' where c: "c = h c'" ..
      from plus.hyps(3) obtain a' where "a'  ideal B" and a: "a = h a'" ..
      from plus.hyps(2) obtain b' where "b'  B" and b: "b = h b'" ..
      from this(1) have "b'  ideal B" by (rule ideal.span_base)
      hence "c' * b'  ideal B" by (rule ideal.span_scale)
      hence "c' * b' + a'  ideal B" using a'  _ by (rule ideal.span_add)
      moreover have "c * b + a = h (c' * b' + a')" by (simp add: a b c h_plus h_times)
      ultimately show ?case by (rule rev_image_eqI)
    qed
  qed
qed

end

end (* theory *)

Theory MPoly_Type_Class

(* Author: Fabian Immler, Alexander Maletzky *)

section ‹Type-Class-Multivariate Polynomials›

theory MPoly_Type_Class
  imports
    Utils
    Power_Products
    More_Modules
begin

text ‹This theory views @{typ "'a 0 'b"} as multivariate polynomials, where type class constraints
  on @{typ 'a} ensure that @{typ 'a} represents something like monomials.›

lemma when_distrib: "f (a when b) = (f a when b)" if "¬ b  f 0 = 0"
  using that by (auto simp: when_def)

definition mapp_2 :: "('a  'b  'c  'd)  ('a 0 'b::zero)  ('a 0 'c::zero)  ('a 0 'd::zero)"
  where "mapp_2 f p q = Abs_poly_mapping (λk. f k (lookup p k) (lookup q k) when k  keys p  keys q)"

lemma lookup_mapp_2:
  "lookup (mapp_2 f p q) k = (f k (lookup p k) (lookup q k) when k  keys p  keys q)"
proof -
  have "lookup (Abs_poly_mapping (λk. f k (lookup p k) (lookup q k) when k  keys p  keys q)) =
        (λk. f k (lookup p k) (lookup q k) when k  keys p  keys q)"
    by (rule Abs_poly_mapping_inverse, simp)
  thus ?thesis by (simp add: mapp_2_def)
qed

lemma lookup_mapp_2_homogenous:
  assumes "f k 0 0 = 0"
  shows "lookup (mapp_2 f p q) k = f k (lookup p k) (lookup q k)"
  by (simp add: lookup_mapp_2 when_def in_keys_iff assms)

lemma mapp_2_cong [fundef_cong]:
  assumes "p = p'" and "q = q'"
  assumes "k. k  keys p'  keys q'  f k (lookup p' k) (lookup q' k) = f' k (lookup p' k) (lookup q' k)"
  shows "mapp_2 f p q = mapp_2 f' p' q'"
  by (rule poly_mapping_eqI, simp add: assms(1, 2) lookup_mapp_2, rule when_cong, fact refl, rule assms(3), blast)

lemma keys_mapp_subset: "keys (mapp_2 f p q)  keys p  keys q"
proof
  fix t
  assume "t  keys (mapp_2 f p q)"
  hence "lookup (mapp_2 f p q) t  0" by (simp add: in_keys_iff) 
  thus "t  keys p  keys q" by (simp add: lookup_mapp_2 when_def split: if_split_asm)
qed

lemma mapp_2_mapp: "mapp_2 (λt a. f t) 0 p = Poly_Mapping.mapp f p"
  by (rule poly_mapping_eqI, simp add: lookup_mapp lookup_mapp_2)

subsection @{const keys}

lemma in_keys_plusI1:
  assumes "t  keys p" and "t  keys q"
  shows "t  keys (p + q)"
  using assms unfolding in_keys_iff lookup_add by simp

lemma in_keys_plusI2:
  assumes "t  keys q" and "t  keys p"
  shows "t  keys (p + q)"
  using assms unfolding in_keys_iff lookup_add by simp

lemma keys_plus_eqI:
  assumes "keys p  keys q = {}"
  shows "keys (p + q) = (keys p  keys q)"
proof
  show "keys (p + q)  keys p  keys q"
    by (simp add: Poly_Mapping.keys_add)
  show "keys p  keys q  keys (p + q)"
    by (simp add: More_MPoly_Type.keys_add assms)
qed
  
lemma keys_uminus: "keys (- p) = keys p"
  by (transfer, auto)

lemma keys_minus: "keys (p - q)  (keys p  keys q)"
  by (transfer, auto)

subsection ‹Monomials›

abbreviation "monomial  (λc t. Poly_Mapping.single t c)"

lemma keys_of_monomial:
  assumes "c  0"
  shows "keys (monomial c t) = {t}"
  using assms by simp

lemma monomial_uminus:
  shows "- monomial c s = monomial (- c) s"
  by (transfer, rule ext, simp add: Poly_Mapping.when_def)

lemma monomial_inj:
  assumes "monomial c s = monomial (d::'b::zero_neq_one) t"
  shows "(c = 0  d = 0)  (c = d  s = t)"
  using assms unfolding poly_mapping_eq_iff
  by (metis (mono_tags, hide_lams) lookup_single_eq lookup_single_not_eq)

definition is_monomial :: "('a 0 'b::zero)  bool"
  where "is_monomial p  card (keys p) = 1"

lemma monomial_is_monomial:
  assumes "c  0"
  shows "is_monomial (monomial c t)"
  using keys_single[of t c] assms by (simp add: is_monomial_def)

lemma is_monomial_monomial:
  assumes "is_monomial p"
  obtains c t where "c  0" and "p = monomial c t"
proof -
  from assms have "card (keys p) = 1" unfolding is_monomial_def .
  then obtain t where sp: "keys p = {t}" by (rule card_1_singletonE)
  let ?c = "lookup p t"
  from sp have "?c  0" by fastforce
  show ?thesis
  proof
    show "p = monomial ?c t"
    proof (intro poly_mapping_keys_eqI)
      from sp show "keys p = keys (monomial ?c t)" using ?c  0 by simp
    next
      fix s
      assume "s  keys p"
      with sp have "s = t" by simp
      show "lookup p s = lookup (monomial ?c t) s" by (simp add: s = t)
    qed
  qed fact
qed
  
lemma is_monomial_uminus: "is_monomial (-p)  is_monomial p"
  unfolding is_monomial_def keys_uminus ..

lemma monomial_not_0:
  assumes "is_monomial p"
  shows "p  0"
  using assms unfolding is_monomial_def by auto

lemma keys_subset_singleton_imp_monomial:
  assumes "keys p  {t}"
  shows "monomial (lookup p t) t = p"
proof (rule poly_mapping_eqI, simp add: lookup_single when_def, rule)
  fix s
  assume "t  s"
  hence "s  keys p" using assms by blast
  thus "lookup p s = 0" by (simp add: in_keys_iff) 
qed

lemma monomial_0I:
  assumes "c = 0"
  shows "monomial c t = 0"
  using assms by transfer (auto)

lemma monomial_0D:
  assumes "monomial c t = 0"
  shows "c = 0"
  using assms by transfer (auto simp: fun_eq_iff when_def; meson)

corollary monomial_0_iff: "monomial c t = 0  c = 0"
  by (rule, erule monomial_0D, erule monomial_0I)

lemma lookup_times_monomial_left: "lookup (monomial c t * p) s = (c * lookup p (s - t) when t adds s)"
  for c::"'b::semiring_0" and t::"'a::comm_powerprod"
proof (induct p rule: poly_mapping_except_induct, simp)
  fix p::"'a 0 'b" and w
  assume "p  0" and "w  keys p"
    and IH: "lookup (monomial c t * except p {w}) s =
             (c * lookup (except p {w}) (s - t) when t adds s)" (is "_ = ?x")
  have "monomial c t * p = monomial c t * (monomial (lookup p w) w + except p {w})"
    by (simp only: plus_except[symmetric])
  also have "... = monomial c t * monomial (lookup p w) w + monomial c t * except p {w}"
    by (simp add: algebra_simps)
  also have "... = monomial (c * lookup p w) (t + w) + monomial c t * except p {w}"
    by (simp only: mult_single)
  finally have "lookup (monomial c t * p) s = lookup (monomial (c * lookup p w) (t + w)) s + ?x"
    by (simp only: lookup_add IH)
  also have "... = (lookup (monomial (c * lookup p w) (t + w)) s +
                    c * lookup (except p {w}) (s - t) when t adds s)"
    by (rule when_distrib, auto simp add: lookup_single when_def)
  also from refl have "... = (c * lookup p (s - t) when t adds s)"
  proof (rule when_cong)
    assume "t adds s"
    then obtain u where u: "s = t + u" ..
    show "lookup (monomial (c * lookup p w) (t + w)) s + c * lookup (except p {w}) (s - t) =
          c * lookup p (s - t)"
      by (simp add: u, cases "u = w", simp_all add: lookup_except lookup_single add.commute)
  qed
  finally show "lookup (monomial c t * p) s = (c * lookup p (s - t) when t adds s)" .
qed

lemma lookup_times_monomial_right: "lookup (p * monomial c t) s = (lookup p (s - t) * c when t adds s)"
  for c::"'b::semiring_0" and t::"'a::comm_powerprod"
proof (induct p rule: poly_mapping_except_induct, simp)
  fix p::"'a 0 'b" and w
  assume "p  0" and "w  keys p"
    and IH: "lookup (except p {w} * monomial c t) s =
             ((lookup (except p {w}) (s - t)) * c when t adds s)"
            (is "_ = ?x")
  have "p * monomial c t = (monomial (lookup p w) w + except p {w}) * monomial c t"
    by (simp only: plus_except[symmetric])
  also have "... = monomial (lookup p w) w * monomial c t + except p {w} * monomial c t"
    by (simp add: algebra_simps)
  also have "... = monomial (lookup p w * c) (w + t) + except p {w} * monomial c t"
    by (simp only: mult_single)
  finally have "lookup (p * monomial c t) s = lookup (monomial (lookup p w * c) (w + t)) s + ?x"
    by (simp only: lookup_add IH)
  also have "... = (lookup (monomial (lookup p w * c) (w + t)) s +
                    lookup (except p {w}) (s - t) * c when t adds s)"
    by (rule when_distrib, auto simp add: lookup_single when_def)
  also from refl have "... = (lookup p (s - t) * c when t adds s)"
  proof (rule when_cong)
    assume "t adds s"
    then obtain u where u: "s = t + u" ..
    show "lookup (monomial (lookup p w * c) (w + t)) s + lookup (except p {w}) (s - t) * c =
          lookup p (s - t) * c"
      by (simp add: u, cases "u = w", simp_all add: lookup_except lookup_single add.commute)
  qed
  finally show "lookup (p * monomial c t) s = (lookup p (s - t) * c when t adds s)" .
qed

subsection ‹Vector-Polynomials›

text ‹From now on we consider multivariate vector-polynomials, i.\,e. vectors of scalar polynomials.
  We do this by adding a @{emph ‹component›} to each power-product, yielding
  @{emph ‹terms›}. Vector-polynomials are then again just linear combinations of terms.
  Note that a term is @{emph ‹not›} the same as a vector of power-products!›

text ‹We use define terms in a locale, such that later on we can interpret the
  locale also by ordinary power-products (without components), exploiting the canonical isomorphism
  between @{typ 'a} and @{typ 'a × unit›}.›

named_theorems term_simps "simplification rules for terms"

locale term_powerprod =
		fixes pair_of_term::"'t  ('a::comm_powerprod × 'k::linorder)"
		fixes term_of_pair::"('a × 'k)  't"
		assumes term_pair [term_simps]: "term_of_pair (pair_of_term v) = v"
		assumes pair_term [term_simps]: "pair_of_term (term_of_pair p) = p"
begin

lemma pair_of_term_injective:
  assumes "pair_of_term u = pair_of_term v"
  shows "u = v"
proof -
  from assms have "term_of_pair (pair_of_term u) = term_of_pair (pair_of_term v)" by (simp only:)
  thus ?thesis by (simp add: term_simps)
qed

corollary pair_of_term_inj: "inj pair_of_term"
  using pair_of_term_injective by (rule injI)

lemma term_of_pair_injective:
  assumes "term_of_pair p = term_of_pair q"
  shows "p = q"
proof -
  from assms have "pair_of_term (term_of_pair p) = pair_of_term (term_of_pair q)" by (simp only:)
  thus ?thesis by (simp add: term_simps)
qed

corollary term_of_pair_inj: "inj term_of_pair"
  using term_of_pair_injective by (rule injI)

definition pp_of_term :: "'t  'a"
  where "pp_of_term v = fst (pair_of_term v)"

definition component_of_term :: "'t  'k"
  where "component_of_term v = snd (pair_of_term v)"

lemma term_of_pair_pair [term_simps]: "term_of_pair (pp_of_term v, component_of_term v) = v"
  by (simp add: pp_of_term_def component_of_term_def term_pair)

lemma pp_of_term_of_pair [term_simps]: "pp_of_term (term_of_pair (t, k)) = t"
  by (simp add: pp_of_term_def pair_term)

lemma component_of_term_of_pair [term_simps]: "component_of_term (term_of_pair (t, k)) = k"
  by (simp add: component_of_term_def pair_term)

subsubsection ‹Additive Structure of Terms›

definition splus :: "'a  't  't" (infixl "" 75)
  where "splus t v = term_of_pair (t + pp_of_term v, component_of_term v)"

definition sminus :: "'t  'a  't" (infixl "" 75)
  where "sminus v t = term_of_pair (pp_of_term v - t, component_of_term v)"

text ‹Note that the argument order in @{const sminus} is reversed compared to the order in @{const splus}.›

definition adds_pp :: "'a  't  bool" (infix "addsp" 50)
  where "adds_pp t v  t adds pp_of_term v"

definition adds_term :: "'t  't  bool" (infix "addst" 50)
  where "adds_term u v  component_of_term u = component_of_term v  pp_of_term u adds pp_of_term v"

lemma pp_of_term_splus [term_simps]: "pp_of_term (t  v) = t + pp_of_term v"
  by (simp add: splus_def term_simps)

lemma component_of_term_splus [term_simps]: "component_of_term (t  v) = component_of_term v"
  by (simp add: splus_def term_simps)

lemma pp_of_term_sminus [term_simps]: "pp_of_term (v  t) = pp_of_term v - t"
  by (simp add: sminus_def term_simps)

lemma component_of_term_sminus [term_simps]: "component_of_term (v  t) = component_of_term v"
  by (simp add: sminus_def term_simps)

lemma splus_sminus [term_simps]: "(t  v)  t = v"
  by (simp add: sminus_def term_simps)

lemma splus_zero [term_simps]: "0  v = v"
  by (simp add: splus_def term_simps)

lemma sminus_zero [term_simps]: "v  0 = v"
  by (simp add: sminus_def term_simps)

lemma splus_assoc [ac_simps]: "(s + t)  v = s  (t  v)"
  by (simp add: splus_def ac_simps term_simps)

lemma splus_left_commute [ac_simps]: "s  (t  v) = t  (s  v)"
  by (simp add: splus_def ac_simps term_simps)

lemma splus_right_canc [term_simps]: "t  v = s  v  t = s"
  by (metis add_right_cancel pp_of_term_splus)

lemma splus_left_canc [term_simps]: "t  v = t  u  v = u"
  by (metis splus_sminus)

lemma adds_ppI [intro?]:
  assumes "v = t  u"
  shows "t addsp v"
  by (simp add: adds_pp_def assms splus_def term_simps)

lemma adds_ppE [elim?]:
  assumes "t addsp v"
  obtains u where "v = t  u"
proof -
  from assms obtain s where *: "pp_of_term v = t + s" unfolding adds_pp_def ..
  have "v = t  (term_of_pair (s, component_of_term v))"
    by (simp add: splus_def term_simps, metis * add.commute term_of_pair_pair)
  thus ?thesis ..
qed

lemma adds_pp_alt: "t addsp v  (u. v = t  u)"
  by (meson adds_ppE adds_ppI)

lemma adds_pp_refl [term_simps]: "(pp_of_term v) addsp v"
  by (simp add: adds_pp_def)

lemma adds_pp_trans [trans]:
  assumes "s adds t" and "t addsp v"
  shows "s addsp v"
proof -
  note assms(1)
  also from assms(2) have "t adds pp_of_term v" by (simp only: adds_pp_def)
  finally show ?thesis by (simp only: adds_pp_def)
qed

lemma zero_adds_pp [term_simps]: "0 addsp v"
  by (simp add: adds_pp_def)

lemma adds_pp_splus:
  assumes "t addsp v"
  shows "t addsp s  v"
  using assms by (simp add: adds_pp_def term_simps)

lemma adds_pp_triv [term_simps]: "t addsp t  v"
  by (simp add: adds_pp_def term_simps)

lemma plus_adds_pp_mono:
  assumes "s adds t"
    and "u addsp v"
  shows "s + u addsp t  v"
  using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_mono)

lemma plus_adds_pp_left:
  assumes "s + t addsp v"
  shows "s addsp v"
  using assms by (simp add: adds_pp_def plus_adds_left)

lemma plus_adds_pp_right:
  assumes "s + t addsp v"
  shows "t addsp v"
  using assms by (simp add: adds_pp_def plus_adds_right)

lemma adds_pp_sminus:
  assumes "t addsp v"
  shows "t  (v  t) = v"
proof -
  from assms adds_pp_alt[of t v] obtain u where u: "v = t  u" by (auto simp: ac_simps)
  hence "v  t = u" by (simp add: term_simps)
  thus ?thesis using u by simp
qed

lemma adds_pp_canc: "t + s addsp (t  v)  s addsp v"
  by (simp add: adds_pp_def adds_canc_2 term_simps)

lemma adds_pp_canc_2: "s + t addsp (t  v)  s addsp v"
  by (simp add: adds_pp_canc add.commute[of s t])

lemma plus_adds_pp_0:
  assumes "(s + t) addsp v"
  shows "s addsp (v  t)"
  using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_0)

lemma plus_adds_ppI_1:
  assumes "t addsp v" and "s addsp (v  t)"
  shows "(s + t) addsp v"
  using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_2)

lemma plus_adds_ppI_2:
  assumes "t addsp v" and "s addsp (v  t)"
  shows "(t + s) addsp v"
  unfolding add.commute[of t s] using assms by (rule plus_adds_ppI_1)

lemma plus_adds_pp: "(s + t) addsp v  (t addsp v  s addsp (v  t))"
  by (simp add: adds_pp_def plus_adds term_simps)

lemma minus_splus:
  assumes "s adds t"
  shows "(t - s)  v = (t  v)  s"
  by (simp add: assms minus_plus sminus_def splus_def term_simps)

lemma minus_splus_sminus:
  assumes "s adds t" and "u addsp v"
  shows "(t - s)  (v  u) = (t  v)  (s + u)"
  using assms minus_plus_minus term_powerprod.adds_pp_def term_powerprod_axioms sminus_def
    splus_def term_simps by fastforce

lemma minus_splus_sminus_cancel:
  assumes "s adds t" and "t addsp v"
  shows "(t - s)  (v  t) = v  s"
  by (simp add: adds_pp_sminus assms minus_splus)

lemma sminus_plus:
  assumes "s addsp v" and "t addsp (v  s)"
  shows "v  (s + t) = (v  s)  t"
  by (simp add: diff_diff_add sminus_def term_simps)

lemma adds_termI [intro?]:
  assumes "v = t  u"
  shows "u addst v"
  by (simp add: adds_term_def assms splus_def term_simps)

lemma adds_termE [elim?]:
  assumes "u addst v"
  obtains t where "v = t  u"
proof -
  from assms have eq: "component_of_term u = component_of_term v" and "pp_of_term u adds pp_of_term v"
    by (simp_all add: adds_term_def)
  from this(2) obtain s where *: "s + pp_of_term u = pp_of_term v" unfolding adds_term_def
    using adds_minus by blast
  have "v = s  u" by (simp add: splus_def eq * term_simps)
  thus ?thesis ..
qed

lemma adds_term_alt: "u addst v  (t. v = t  u)"
  by (meson adds_termE adds_termI)

lemma adds_term_refl [term_simps]: "v addst v"
  by (simp add: adds_term_def)

lemma adds_term_trans [trans]:
  assumes "u addst v" and "v addst w"
  shows "u addst w"
  using assms unfolding adds_term_def using adds_trans by auto

lemma adds_term_splus:
  assumes "u addst v"
  shows "u addst s  v"
  using assms by (simp add: adds_term_def term_simps)

lemma adds_term_triv [term_simps]: "v addst t  v"
  by (simp add: adds_term_def term_simps)

lemma splus_adds_term_mono:
  assumes "s adds t"
    and "u addst v"
  shows "s  u addst t  v"
  using assms by (auto simp: adds_term_def term_simps intro: plus_adds_mono)

lemma splus_adds_term:
  assumes "t  u addst v"
  shows "u addst v"
  using assms by (auto simp add: adds_term_def term_simps elim: plus_adds_right)

lemma adds_term_adds_pp:
  "u addst v  (component_of_term u = component_of_term v  pp_of_term u addsp v)"
  by (simp add: adds_term_def adds_pp_def)

lemma adds_term_canc: "t  u addst t  v  u addst v"
  by (simp add: adds_term_def adds_canc_2 term_simps)

lemma adds_term_canc_2: "s  v addst t  v  s adds t"
  by (simp add: adds_term_def adds_canc term_simps)

lemma splus_adds_term_0:
  assumes "t  u addst v"
  shows "u addst (v  t)"
  using assms by (simp add: adds_term_def add.commute[of t] term_simps) (auto intro: plus_adds_0)

lemma splus_adds_termI_1:
  assumes "t addsp v" and "u addst (v  t)"
  shows "t  u addst v"
  using assms apply (simp add: adds_term_def term_simps) by (metis add.commute adds_pp_def plus_adds_2)

lemma splus_adds_term_iff: "t  u addst v  (t addsp v  u addst (v  t))"
  by (metis adds_ppI adds_pp_splus adds_termE splus_adds_termI_1 splus_adds_term_0)

lemma adds_minus_splus:
  assumes "pp_of_term u adds t"
  shows "(t - pp_of_term u)  u = term_of_pair (t, component_of_term u)"
  by (simp add: splus_def adds_minus[OF assms])

subsubsection ‹Projections and Conversions›

lift_definition proj_poly :: "'k  ('t 0 'b)  ('a 0 'b::zero)"
  is "λk p t. p (term_of_pair (t, k))"
proof -
  fix k::'k and p::"'t  'b"
  assume fin: "finite {v. p v  0}"
  have "{t. p (term_of_pair (t, k))  0}  pp_of_term ` {v. p v  0}"
  proof (rule, simp)
    fix t
    assume "p (term_of_pair (t, k))  0"
    hence *: "term_of_pair (t, k)  {v. p v  0}" by simp
    have "t = pp_of_term (term_of_pair (t, k))" by (simp add: pp_of_term_def pair_term)
    from this * show "t  pp_of_term ` {v. p v  0}" ..
  qed
  moreover from fin have "finite (pp_of_term ` {v. p v  0})" by (rule finite_imageI)
  ultimately show "finite {t. p (term_of_pair (t, k))  0}" by (rule finite_subset)
qed

definition vectorize_poly :: "('t 0 'b)  ('k 0 ('a 0 'b::zero))"
  where "vectorize_poly p = Abs_poly_mapping (λk. proj_poly k p)"

definition atomize_poly :: "('k 0 ('a 0 'b))  ('t 0 'b::zero)"
  where "atomize_poly p = Abs_poly_mapping (λv. lookup (lookup p (component_of_term v)) (pp_of_term v))"

lemma lookup_proj_poly: "lookup (proj_poly k p) t = lookup p (term_of_pair (t, k))"
  by (transfer, simp)

lemma lookup_vectorize_poly: "lookup (vectorize_poly p) k = proj_poly k p"
proof -
  have "lookup (Abs_poly_mapping (λk. proj_poly k p)) = (λk. proj_poly k p)"
  proof (rule Abs_poly_mapping_inverse, simp)
    have "{k. proj_poly k p  0}  component_of_term ` keys p"
    proof (rule, simp)
      fix k
      assume "proj_poly k p  0"
      hence "keys (proj_poly k p)  {}" using poly_mapping_eq_zeroI by blast
      then obtain t where "lookup (proj_poly k p) t  0" by blast
      hence "term_of_pair (t, k)  keys p" by (simp add: lookup_proj_poly in_keys_iff)
      hence "component_of_term (term_of_pair (t, k))  component_of_term ` keys p" by fastforce
      thus "k  component_of_term ` keys p" by (simp add: term_simps)
    qed
    moreover from finite_keys have "finite (component_of_term ` keys p)" by (rule finite_imageI)
    ultimately show "finite {k. proj_poly k p  0}" by (rule finite_subset)
  qed
  thus ?thesis by (simp add: vectorize_poly_def)
qed

lemma lookup_atomize_poly:
  "lookup (atomize_poly p) v = lookup (lookup p (component_of_term v)) (pp_of_term v)"
proof -
  have "lookup (Abs_poly_mapping (λv. lookup (lookup p (component_of_term v)) (pp_of_term v))) =
        (λv. lookup (lookup p (component_of_term v)) (pp_of_term v))"
  proof (rule Abs_poly_mapping_inverse, simp)
    have "{v. pp_of_term v  keys (lookup p (component_of_term v))} 
          (kkeys p. (λt. term_of_pair (t, k)) ` keys (lookup p k))" (is "_  ?A")
    proof (rule, simp)
      fix v
      assume *: "pp_of_term v  keys (lookup p (component_of_term v))"
      hence "keys (lookup p (component_of_term v))  {}" by blast
      hence "lookup p (component_of_term v)  0" by auto
      hence "component_of_term v  keys p" (is "?k  _") 
        by (simp add: in_keys_iff)
      thus "kkeys p. v  (λt. term_of_pair (t, k)) ` keys (lookup p k)"
      proof
        have "v = term_of_pair (pp_of_term v, component_of_term v)" by (simp add: term_simps)
        from this * show "v  (λt. term_of_pair (t, ?k)) ` keys (lookup p ?k)" ..
      qed
    qed
    moreover have "finite ?A" by (rule, fact finite_keys, rule finite_imageI, rule finite_keys)
    ultimately show "finite {x. lookup (lookup p (component_of_term x)) (pp_of_term x)  0}"
      by (simp add: finite_subset in_keys_iff)
  qed
  thus ?thesis by (simp add: atomize_poly_def)
qed

lemma keys_proj_poly: "keys (proj_poly k p) = pp_of_term ` {xkeys p. component_of_term x = k}"
proof
  show "keys (proj_poly k p)  pp_of_term ` {xkeys p. component_of_term x = k}"
  proof
    fix t
    assume "t  keys (proj_poly k p)"
    hence "lookup (proj_poly k p) t  0" by (simp add: in_keys_iff)
    hence "term_of_pair (t, k)  keys p" by (simp add: in_keys_iff lookup_proj_poly)
    hence "term_of_pair (t, k)  {xkeys p. component_of_term x = k}" by (simp add: term_simps)
    hence "pp_of_term (term_of_pair (t, k))  pp_of_term ` {xkeys p. component_of_term x = k}" by (rule imageI)
    thus "t  pp_of_term ` {xkeys p. component_of_term x = k}" by (simp only: pp_of_term_of_pair)
  qed
next
  show "pp_of_term ` {xkeys p. component_of_term x = k}  keys (proj_poly k p)"
  proof
    fix t
    assume "t  pp_of_term ` {xkeys p. component_of_term x = k}"
    then obtain x where "x  {xkeys p. component_of_term x = k}" and "t = pp_of_term x" ..
    from this(1) have "x  keys p" and "k = component_of_term x" by simp_all
    from this(2) have "x = term_of_pair (t, k)" by (simp add: term_of_pair_pair t = pp_of_term x)
    with x  keys p have "lookup p (term_of_pair (t, k))  0" by (simp add: in_keys_iff)
    hence "lookup (proj_poly k p) t  0" by (simp add: lookup_proj_poly)
    thus "t  keys (proj_poly k p)" by (simp add: in_keys_iff)
  qed
qed

lemma keys_vectorize_poly: "keys (vectorize_poly p) = component_of_term ` keys p"
proof
  show "keys (vectorize_poly p)  component_of_term ` keys p"
  proof
    fix k
    assume "k  keys (vectorize_poly p)"
    hence "lookup (vectorize_poly p) k  0" by (simp add: in_keys_iff)
    hence "proj_poly k p  0" by (simp add: lookup_vectorize_poly)
    then obtain t where "lookup (proj_poly k p) t  0" using aux by blast
    hence "term_of_pair (t, k)  keys p" by (simp add: lookup_proj_poly in_keys_iff)
    hence "component_of_term (term_of_pair (t, k))  component_of_term ` keys p" by (rule imageI)
    thus "k  component_of_term ` keys p" by (simp only: component_of_term_of_pair)
  qed
next
  show "component_of_term ` keys p  keys (vectorize_poly p)"
  proof
    fix k
    assume "k  component_of_term ` keys p"
    then obtain x where "x  keys p" and "k = component_of_term x" ..
    from this(2) have "term_of_pair (pp_of_term x, k) = x" by (simp add: term_of_pair_pair)
    with x  keys p have "lookup p (term_of_pair (pp_of_term x, k))  0" by (simp add: in_keys_iff)
    hence "lookup (proj_poly k p) (pp_of_term x)  0" by (simp add: lookup_proj_poly)
    hence "proj_poly k p  0" by auto
    hence "lookup (vectorize_poly p) k  0" by (simp add: lookup_vectorize_poly)
    thus "k  keys (vectorize_poly p)" by (simp add: in_keys_iff)
  qed
qed

lemma keys_atomize_poly:
  "keys (atomize_poly p) = (kkeys p. (λt. term_of_pair (t, k)) ` keys (lookup p k))" (is "?l = ?r")
proof
  show "?l  ?r"
  proof
    fix v
    assume "v  ?l"
    hence "lookup (atomize_poly p) v  0" by (simp add: in_keys_iff)
    hence *: "pp_of_term v  keys (lookup p (component_of_term v))" by (simp add: in_keys_iff lookup_atomize_poly)
    hence "lookup p (component_of_term v)  0" by fastforce
    hence "component_of_term v  keys p" by (simp add: in_keys_iff)
    thus "v  ?r"
    proof
      from * have "term_of_pair (pp_of_term v, component_of_term v) 
                    (λt. term_of_pair (t, component_of_term v)) ` keys (lookup p (component_of_term v))"
        by (rule imageI)
      thus "v  (λt. term_of_pair (t, component_of_term v)) ` keys (lookup p (component_of_term v))"
        by (simp only: term_of_pair_pair)
    qed
  qed
next
  show "?r  ?l"
  proof
    fix v
    assume "v  ?r"
    then obtain k where "k  keys p" and "v  (λt. term_of_pair (t, k)) ` keys (lookup p k)" ..
    from this(2) obtain t where "t  keys (lookup p k)" and v: "v = term_of_pair (t, k)" ..
    from this(1) have "lookup (atomize_poly p) v  0" by (simp add: v lookup_atomize_poly in_keys_iff term_simps)
    thus "v  ?l" by (simp add: in_keys_iff)
  qed
qed

lemma proj_atomize_poly [term_simps]: "proj_poly k (atomize_poly p) = lookup p k"
  by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_atomize_poly term_simps)

lemma vectorize_atomize_poly [term_simps]: "vectorize_poly (atomize_poly p) = p"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)

lemma atomize_vectorize_poly [term_simps]: "atomize_poly (vectorize_poly p) = p"
  by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_vectorize_poly lookup_proj_poly term_simps)

lemma proj_zero [term_simps]: "proj_poly k 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_proj_poly)

lemma proj_plus: "proj_poly k (p + q) = proj_poly k p + proj_poly k q"
  by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_add)

lemma proj_uminus [term_simps]: "proj_poly k (- p) = - proj_poly k p"
  by (rule poly_mapping_eqI, simp add: lookup_proj_poly)

lemma proj_minus: "proj_poly k (p - q) = proj_poly k p - proj_poly k q"
  by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_minus)

lemma vectorize_zero [term_simps]: "vectorize_poly 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)

lemma vectorize_plus: "vectorize_poly (p + q) = vectorize_poly p + vectorize_poly q"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly lookup_add proj_plus)

lemma vectorize_uminus [term_simps]: "vectorize_poly (- p) = - vectorize_poly p"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)

lemma vectorize_minus: "vectorize_poly (p - q) = vectorize_poly p - vectorize_poly q"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly lookup_minus proj_minus)

lemma atomize_zero [term_simps]: "atomize_poly 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_atomize_poly)

lemma atomize_plus: "atomize_poly (p + q) = atomize_poly p + atomize_poly q"
  by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_add)

lemma atomize_uminus [term_simps]: "atomize_poly (- p) = - atomize_poly p"
  by (rule poly_mapping_eqI, simp add: lookup_atomize_poly)

lemma atomize_minus: "atomize_poly (p - q) = atomize_poly p - atomize_poly q"
  by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_minus)

lemma proj_monomial:
  "proj_poly k (monomial c v) = (monomial c (pp_of_term v) when component_of_term v = k)"
proof (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_single when_def term_simps, intro impI)
  fix t
  assume 1: "pp_of_term v = t" and 2: "component_of_term v = k"
  assume "v  term_of_pair (t, k)"
  moreover have "v = term_of_pair (t, k)" by (simp add: 1[symmetric] 2[symmetric] term_simps)
  ultimately show "c = 0" ..
qed

lemma vectorize_monomial:
  "vectorize_poly (monomial c v) = monomial (monomial c (pp_of_term v)) (component_of_term v)"
  by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly proj_monomial lookup_single)

lemma atomize_monomial_monomial:
  "atomize_poly (monomial (monomial c t) k) = monomial c (term_of_pair (t, k))"
proof -
  define v where "v = term_of_pair (t, k)"
  have t: "t = pp_of_term v" and k: "k = component_of_term v" by (simp_all add: v_def term_simps)
  show ?thesis by (simp add: t k vectorize_monomial[symmetric] term_simps)
qed

lemma poly_mapping_eqI_proj:
  assumes "k. proj_poly k p = proj_poly k q"
  shows "p = q"
proof (rule poly_mapping_eqI)
  fix v::'t
  have "proj_poly (component_of_term v) p = proj_poly (component_of_term v) q" by (rule assms)
  hence "lookup (proj_poly (component_of_term v) p) (pp_of_term v) =
          lookup (proj_poly (component_of_term v) q) (pp_of_term v)" by simp
  thus "lookup p v = lookup q v" by (simp add: lookup_proj_poly term_simps)
qed

subsection ‹Scalar Multiplication by Monomials›

definition monom_mult :: "'b::semiring_0  'a::comm_powerprod  ('t 0 'b)  ('t 0 'b)"
  where "monom_mult c t p = Abs_poly_mapping (λv. if t addsp v then c * (lookup p (v  t)) else 0)"

lemma keys_monom_mult_aux:
  "{v. (if t addsp v then c * lookup p (v  t) else 0)  0}  (⊕) t ` keys p" (is "?l  ?r")
  for c::"'b::semiring_0"
proof
  fix v::'t
  assume "v  ?l"
  hence "(if t addsp v then c * lookup p (v  t) else 0)  0" by simp
  hence "t addsp v" and cp_not_zero: "c * lookup p (v  t)  0" by (simp_all split: if_split_asm)
  show "v  ?r"
  proof
    from adds_pp_sminus[OF t addsp v] show "v = t  (v  t)" by simp
  next
    from mult_not_zero[OF cp_not_zero] show "v  t  keys p"
      by (simp add: in_keys_iff)
  qed
qed

lemma lookup_monom_mult:
  "lookup (monom_mult c t p) v = (if t addsp v then c * lookup p (v  t) else 0)"
proof -
  have "lookup (monom_mult c t p) = (λv. if t addsp v then c * lookup p (v  t) else 0)"
    unfolding monom_mult_def
  proof (rule Abs_poly_mapping_inverse)
    from finite_keys have "finite ((⊕) t ` keys p)" ..
    with keys_monom_mult_aux have "finite {v. (if t addsp v then c * lookup p (v  t) else 0)  0}"
      by (rule finite_subset)
    thus "(λv. if t addsp v then c * lookup p (v  t) else 0)  {f. finite {x. f x  0}}" by simp
  qed
  thus ?thesis by simp
qed

lemma lookup_monom_mult_plus:
  "lookup (monom_mult c t p) (t  v) = (c::'b::semiring_0) * lookup p v"
  by (simp add: lookup_monom_mult term_simps)

lemma monom_mult_assoc: "monom_mult c s (monom_mult d t p) = monom_mult (c * d) (s + t) p"
proof (rule poly_mapping_eqI, simp add: lookup_monom_mult sminus_plus ac_simps, intro conjI impI)
  fix v
  assume "s addsp v" and "t addsp v  s"
  hence "s + t addsp v" by (rule plus_adds_ppI_2)
  moreover assume "¬ s + t addsp v"
  ultimately show "c * (d * lookup p (v  s  t)) = 0" by simp
next
  fix v
  assume "s + t addsp v"
  hence "s addsp v" by (rule plus_adds_pp_left)
  moreover assume "¬ s addsp v"
  ultimately show "c * (d * lookup p (v  (s + t))) = 0" by simp
next
  fix v
  assume "s + t addsp v"
  hence "t addsp v  s" by (simp add: add.commute plus_adds_pp_0)
  moreover assume "¬ t addsp v  s"
  ultimately show "c * (d * lookup p (v  (s + t))) = 0" by simp
qed

lemma monom_mult_uminus_left: "monom_mult (- c) t p = - monom_mult (c::'b::ring) t p"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult)

lemma monom_mult_uminus_right: "monom_mult c t (- p) = - monom_mult (c::'b::ring) t p"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult)

lemma uminus_monom_mult: "- p = monom_mult (-1::'b::comm_ring_1) 0 p"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult term_simps)

lemma monom_mult_dist_left: "monom_mult (c + d) t p = (monom_mult c t p) + (monom_mult d t p)"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult lookup_add algebra_simps)

lemma monom_mult_dist_left_minus:
  "monom_mult (c - d) t p = (monom_mult c t p) - (monom_mult (d::'b::ring) t p)"
  using monom_mult_dist_left[of c "-d" t p] monom_mult_uminus_left[of d t p] by simp

lemma monom_mult_dist_right:
  "monom_mult c t (p + q) = (monom_mult c t p) + (monom_mult c t q)"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult lookup_add algebra_simps)

lemma monom_mult_dist_right_minus:
  "monom_mult c t (p - q) = (monom_mult c t p) - (monom_mult (c::'b::ring) t q)"
  using monom_mult_dist_right[of c t p "-q"] monom_mult_uminus_right[of c t q] by simp

lemma monom_mult_zero_left [simp]: "monom_mult 0 t p = 0"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult)

lemma monom_mult_zero_right [simp]: "monom_mult c t 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult)

lemma monom_mult_one_left [simp]: "(monom_mult (1::'b::semiring_1) 0 p) = p"
  by (rule poly_mapping_eqI, simp add: lookup_monom_mult term_simps)

lemma monom_mult_monomial:
  "monom_mult c s (monomial d v) = monomial (c * (d::'b::semiring_0)) (s  v)"
  by (rule poly_mapping_eqI, auto simp add: lookup_monom_mult lookup_single adds_pp_alt when_def term_simps, metis)

lemma monom_mult_eq_zero_iff: "(monom_mult c t p = 0)  ((c::'b::semiring_no_zero_divisors) = 0  p = 0)"
proof
  assume eq: "monom_mult c t p = 0"
  show "c = 0  p = 0"
  proof (rule ccontr, simp)
    assume "c  0  p  0"
    hence "c  0" and "p  0" by simp_all
    from lookup_zero poly_mapping_eq_iff[of p 0] p  0 obtain v where "lookup p v  0" by fastforce
    from eq lookup_zero have "lookup (monom_mult c t p) (t  v) = 0" by simp
    hence "c * lookup p v = 0" by (simp only: lookup_monom_mult_plus)
    with c  0 ‹lookup p v  0 show False by auto
  qed
next
  assume "c = 0  p = 0"
  with monom_mult_zero_left[of t p] monom_mult_zero_right[of c t] show "monom_mult c t p = 0" by auto
qed

lemma lookup_monom_mult_zero: "lookup (monom_mult c 0 p) t = c * lookup p t"
proof -
  have "lookup (monom_mult c 0 p) t = lookup (monom_mult c 0 p) (0  t)" by (simp add: term_simps)
  also have "... = c * lookup p t" by (rule lookup_monom_mult_plus)
  finally show ?thesis .
qed

lemma monom_mult_inj_1:
  assumes "monom_mult c1 t p = monom_mult c2 t p"
    and "(p::(_ 0 'b::semiring_no_zero_divisors_cancel))  0"
  shows "c1 = c2"
proof -
  from assms(2) have "keys p  {}" using poly_mapping_eq_zeroI by blast
  then obtain v where "v  keys p" by blast
  hence *: "lookup p v  0" by (simp add: in_keys_iff)
  from assms(1) have "lookup (monom_mult c1 t p) (t  v) = lookup (monom_mult c2 t p) (t  v)"
    by simp
  hence "c1 * lookup p v = c2 * lookup p v" by (simp only: lookup_monom_mult_plus)
  with * show ?thesis by auto
qed

text ‹Multiplication by a monomial is injective in the second argument (the power-product) only in
  context @{locale ordered_powerprod}; see lemma monom_mult_inj_2› below.›

lemma monom_mult_inj_3:
  assumes "monom_mult c t p1 = monom_mult c t (p2::(_ 0 'b::semiring_no_zero_divisors_cancel))"
    and "c  0"
  shows "p1 = p2"
proof (rule poly_mapping_eqI)
  fix v
  from assms(1) have "lookup (monom_mult c t p1) (t  v) = lookup (monom_mult c t p2) (t  v)"
    by simp
  hence "c * lookup p1 v = c * lookup p2 v" by (simp only: lookup_monom_mult_plus)
  with assms(2) show "lookup p1 v = lookup p2 v" by simp
qed
    
lemma keys_monom_multI:
  assumes "v  keys p" and "c  (0::'b::semiring_no_zero_divisors)"
  shows "t  v  keys (monom_mult c t p)"
  using assms unfolding in_keys_iff lookup_monom_mult_plus by simp

lemma keys_monom_mult_subset: "keys (monom_mult c t p)  ((⊕) t) ` (keys p)"
proof -
  have "keys (monom_mult c t p)  {v. (if t addsp v then c * lookup p (v  t) else 0)  0}" (is "_  ?A")
  proof
    fix v
    assume "v  keys (monom_mult c t p)"
    hence "lookup (monom_mult c t p) v  0" by (simp add: in_keys_iff)
    thus "v  ?A" unfolding lookup_monom_mult by simp
  qed
  also note keys_monom_mult_aux
  finally show ?thesis .
qed

lemma keys_monom_multE:
  assumes "v  keys (monom_mult c t p)"
  obtains u where "u  keys p" and "v = t  u"
proof -
  note assms
  also have "keys (monom_mult c t p)  ((⊕) t) ` (keys p)" by (fact keys_monom_mult_subset)
  finally have "v  ((⊕) t) ` (keys p)" .
  then obtain u where "u  keys p" and "v = t  u" ..
  thus ?thesis ..
qed

lemma keys_monom_mult:
  assumes "c  (0::'b::semiring_no_zero_divisors)"
  shows "keys (monom_mult c t p) = ((⊕) t) ` (keys p)"
proof (rule, fact keys_monom_mult_subset, rule)
  fix v
  assume "v  (⊕) t ` keys p"
  then obtain u where "u  keys p" and v: "v = t  u" ..
  from u  keys p assms show "v  keys (monom_mult c t p)" unfolding v by (rule keys_monom_multI)
qed

lemma monom_mult_when: "monom_mult c t (p when P) = ((monom_mult c t p) when P)"
  by (cases P, simp_all)

lemma when_monom_mult: "monom_mult (c when P) t p = ((monom_mult c t p) when P)"
  by (cases P, simp_all)

lemma monomial_power: "(monomial c t) ^ n = monomial (c ^ n) (i=0..<n. t)"
  by (induct n, simp_all add: mult_single monom_mult_monomial add.commute)

subsection ‹Component-wise Lifting›

text ‹Component-wise lifting of functions on @{typ "'a 0 'b"} to functions on @{typ "'t 0 'b"}.›

definition lift_poly_fun_2 :: "(('a 0 'b)  ('a 0 'b)  ('a 0 'b))  ('t 0 'b)  ('t 0 'b)  ('t 0 'b::zero)"
  where "lift_poly_fun_2 f p q = atomize_poly (mapp_2 (λ_. f) (vectorize_poly p) (vectorize_poly q))"

definition lift_poly_fun :: "(('a 0 'b)  ('a 0 'b))  ('t 0 'b)  ('t 0 'b::zero)"
  where "lift_poly_fun f p = lift_poly_fun_2 (λ_. f) 0 p"

lemma lookup_lift_poly_fun_2:
  "lookup (lift_poly_fun_2 f p q) v =
    (lookup (f (proj_poly (component_of_term v) p) (proj_poly (component_of_term v) q)) (pp_of_term v)
        when component_of_term v  keys (vectorize_poly p)  keys (vectorize_poly q))"
  by (simp add: lift_poly_fun_2_def lookup_atomize_poly lookup_mapp_2 lookup_vectorize_poly
      when_distrib[of _ "λq. lookup q (pp_of_term v)", OF lookup_zero])

lemma lookup_lift_poly_fun:
  "lookup (lift_poly_fun f p) v =
    (lookup (f (proj_poly (component_of_term v) p)) (pp_of_term v) when component_of_term v  keys (vectorize_poly p))"
  by (simp add: lift_poly_fun_def lookup_lift_poly_fun_2 term_simps)

lemma lookup_lift_poly_fun_2_homogenous:
  assumes "f 0 0 = 0"
  shows "lookup (lift_poly_fun_2 f p q) v =
         lookup (f (proj_poly (component_of_term v) p) (proj_poly (component_of_term v) q)) (pp_of_term v)"
  by (simp add: lookup_lift_poly_fun_2 when_def in_keys_iff lookup_vectorize_poly assms)

lemma proj_lift_poly_fun_2_homogenous:
  assumes "f 0 0 = 0"
  shows "proj_poly k (lift_poly_fun_2 f p q) = f (proj_poly k p) (proj_poly k q)"
  by (rule poly_mapping_eqI,
      simp add: lookup_proj_poly lookup_lift_poly_fun_2_homogenous[of f, OF assms] term_simps)

lemma lookup_lift_poly_fun_homogenous:
  assumes "f 0 = 0"
  shows "lookup (lift_poly_fun f p) v = lookup (f (proj_poly (component_of_term v) p)) (pp_of_term v)"
  by (simp add: lookup_lift_poly_fun when_def in_keys_iff lookup_vectorize_poly assms)

lemma proj_lift_poly_fun_homogenous:
  assumes "f 0 = 0"
  shows "proj_poly k (lift_poly_fun f p) = f (proj_poly k p)"
  by (rule poly_mapping_eqI,
      simp add: lookup_proj_poly lookup_lift_poly_fun_homogenous[of f, OF assms] term_simps)

subsection ‹Component-wise Multiplication›

definition mult_vec :: "('t 0 'b)  ('t 0 'b)  ('t 0 'b::semiring_0)" (infixl "**" 75)
  where "mult_vec = lift_poly_fun_2 (*)"

lemma lookup_mult_vec:
  "lookup (p ** q) v = lookup ((proj_poly (component_of_term v) p) * (proj_poly (component_of_term v) q)) (pp_of_term v)"
  unfolding mult_vec_def by (rule lookup_lift_poly_fun_2_homogenous, simp)

lemma proj_mult_vec [term_simps]: "proj_poly k (p ** q) = (proj_poly k p) * (proj_poly k q)"
  unfolding mult_vec_def by (rule proj_lift_poly_fun_2_homogenous, simp)

lemma mult_vec_zero_left: "0 ** p = 0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps)

lemma mult_vec_zero_right: "p ** 0 = 0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps)

lemma mult_vec_assoc: "(p ** q) ** r = p ** (q ** r)"
  by (rule poly_mapping_eqI_proj, simp add: ac_simps term_simps)

lemma mult_vec_distrib_right: "(p + q) ** r = p ** r + q ** r"
  by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)

lemma mult_vec_distrib_left: "r ** (p + q) = r ** p + r ** q"
  by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)

lemma mult_vec_minus_mult_left: "(- p) ** q = - (p ** q)"
  by (rule sym, rule minus_unique, simp add: mult_vec_distrib_right[symmetric] mult_vec_zero_left)

lemma mult_vec_minus_mult_right: "p ** (- q) = - (p ** q)"
  by (rule sym, rule minus_unique, simp add: mult_vec_distrib_left [symmetric] mult_vec_zero_right)

lemma minus_mult_vec_minus: "(- p) ** (- q) = p ** q"
  by (simp add: mult_vec_minus_mult_left mult_vec_minus_mult_right)

lemma minus_mult_vec_commute: "(- p) ** q = p ** (- q)"
  by (simp add: mult_vec_minus_mult_left mult_vec_minus_mult_right)

lemma mult_vec_right_diff_distrib: "r ** (p - q) = r ** p - r ** q"
  for r::"_ 0 'b::ring"
  using mult_vec_distrib_left [of r p "- q"] by (simp add: mult_vec_minus_mult_right)

lemma mult_vec_left_diff_distrib: "(p - q) ** r = p ** r - q ** r"
  for p::"_ 0 'b::ring"
  using mult_vec_distrib_right [of p "- q" r] by (simp add: mult_vec_minus_mult_left)

lemma mult_vec_commute: "p ** q = q ** p" for p::"_ 0 'b::comm_semiring_0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps ac_simps)

lemma mult_vec_left_commute: "p ** (q ** r) = q ** (p ** r)"
  for p::"_ 0 'b::comm_semiring_0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps ac_simps)

lemma mult_vec_monomial_monomial:
  "(monomial c u) ** (monomial d v) =
          (monomial (c * d) (term_of_pair (pp_of_term u + pp_of_term v, component_of_term u)) when
            component_of_term u = component_of_term v)"
  by (rule poly_mapping_eqI_proj, simp add: proj_monomial mult_single when_def term_simps)

lemma mult_vec_rec_left: "p ** q = monomial (lookup p v) v ** q + (except p {v}) ** q"
proof -
  from plus_except[of p v] have "p ** q = (monomial (lookup p v) v + except p {v}) ** q" by simp
  also have "... = monomial (lookup p v) v ** q + except p {v} ** q"
    by (simp only: mult_vec_distrib_right)
  finally show ?thesis .
qed

lemma mult_vec_rec_right: "p ** q = p ** monomial (lookup q v) v + p ** except q {v}"
proof -
  have "p ** monomial (lookup q v) v + p ** except q {v} = p ** (monomial (lookup q v) v + except q {v})"
    by (simp only: mult_vec_distrib_left)
  also have "... = p ** q" by (simp only: plus_except[of q v, symmetric])
  finally show ?thesis by simp
qed

lemma in_keys_mult_vecE:
  assumes "w  keys (p ** q)"
  obtains u v where "u  keys p" and "v  keys q" and "component_of_term u = component_of_term v"
    and "w = term_of_pair (pp_of_term u + pp_of_term v, component_of_term u)"
proof -
  from assms have "0  lookup (p ** q) w" by (simp add: in_keys_iff)
  also have "lookup (p ** q) w =
      lookup ((proj_poly (component_of_term w) p) * (proj_poly (component_of_term w) q)) (pp_of_term w)"
    by (fact lookup_mult_vec)
  finally have "pp_of_term w  keys ((proj_poly (component_of_term w) p) * (proj_poly (component_of_term w) q))"
    by (simp add: in_keys_iff)
  from this keys_mult
  have "pp_of_term w  {t + s |t s. t  keys (proj_poly (component_of_term w) p) 
                                   s  keys (proj_poly (component_of_term w) q)}" ..
  then obtain t s where 1: "t  keys (proj_poly (component_of_term w) p)"
    and 2: "s  keys (proj_poly (component_of_term w) q)"
    and eq: "pp_of_term w = t + s" by fastforce
  let ?u = "term_of_pair (t, component_of_term w)"
  let ?v = "term_of_pair (s, component_of_term w)"
  from 1 have "?u  keys p" by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
  moreover from 2 have "?v  keys q" by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
  moreover have "component_of_term ?u = component_of_term ?v" by (simp add: term_simps)
  moreover have "w = term_of_pair (pp_of_term ?u + pp_of_term ?v, component_of_term ?u)"
    by (simp add: eq[symmetric] term_simps)
  ultimately show ?thesis ..
qed

lemma lookup_mult_vec_monomial_left:
  "lookup (monomial c v ** p) u =
        (c * lookup p (term_of_pair (pp_of_term u - pp_of_term v, component_of_term u)) when v addst u)"
proof -
  have eq1: "lookup ((monomial c (pp_of_term v) when component_of_term v = component_of_term u) * proj_poly (component_of_term u) p)
                (pp_of_term u) =
        (lookup ((monomial c (pp_of_term v)) * proj_poly (component_of_term u) p) (pp_of_term u) when
                component_of_term v = component_of_term u)"
    by (rule when_distrib, simp)
  show ?thesis
    by (simp add: lookup_mult_vec proj_monomial eq1 lookup_times_monomial_left when_when
        adds_term_def lookup_proj_poly conj_commute)
qed

lemma lookup_mult_vec_monomial_right:
  "lookup (p ** monomial c v) u =
        (lookup p (term_of_pair (pp_of_term u - pp_of_term v, component_of_term u)) * c when v addst u)"
proof -
  have eq1: "lookup (proj_poly (component_of_term u) p * (monomial c (pp_of_term v) when component_of_term v = component_of_term u))
                (pp_of_term u) =
        (lookup (proj_poly (component_of_term u) p * (monomial c (pp_of_term v))) (pp_of_term u) when
                component_of_term v = component_of_term u)"
    by (rule when_distrib, simp)
  show ?thesis
    by (simp add: lookup_mult_vec proj_monomial eq1 lookup_times_monomial_right when_when
        adds_term_def lookup_proj_poly conj_commute)
qed

subsection ‹Scalar Multiplication›

definition mult_scalar :: "('a 0 'b)  ('t 0 'b)  ('t 0 'b::semiring_0)" (infixl "" 75)
  where "mult_scalar p = lift_poly_fun ((*) p)"

lemma lookup_mult_scalar:
  "lookup (p  q) v = lookup (p * (proj_poly (component_of_term v) q)) (pp_of_term v)"
  unfolding mult_scalar_def by (rule lookup_lift_poly_fun_homogenous, simp)

lemma lookup_mult_scalar_explicit:
  "lookup (p  q) u = (tkeys p. lookup p t * (vkeys q. lookup q v when u = t  v))"
proof -
  let ?f = "λt s. lookup (proj_poly (component_of_term u) q) s when pp_of_term u = t + s"
  note lookup_mult_scalar
  also have "lookup (p * proj_poly (component_of_term u) q) (pp_of_term u) =
              (t. lookup p t * (Sum_any (?f t)))"
    by (fact lookup_mult)
  also from finite_keys have " = (tkeys p. lookup p t * (Sum_any (?f t)))"
    by (rule Sum_any.expand_superset) (auto simp: in_keys_iff dest: mult_not_zero)
  also from refl have " = (tkeys p. lookup p t * (vkeys q. lookup q v when u = t  v))"
  proof (rule sum.cong)
    fix t
    assume "t  keys p"
    from finite_keys have "Sum_any (?f t) = (skeys (proj_poly (component_of_term u) q). ?f t s)"
      by (rule Sum_any.expand_superset) (auto simp: in_keys_iff)
    also have " = (v{x  keys q. component_of_term x = component_of_term u}. ?f t (pp_of_term v))"
      unfolding keys_proj_poly
    proof (intro sum.reindex[simplified o_def] inj_onI)
      fix v1 v2
      assume "v1  {x  keys q. component_of_term x = component_of_term u}"
        and "v2  {x  keys q. component_of_term x = component_of_term u}"
      hence "component_of_term v1 = component_of_term v2" by simp
      moreover assume "pp_of_term v1 = pp_of_term v2"
      ultimately show "v1 = v2" by (metis term_of_pair_pair)
    qed
    also from finite_keys have " = (vkeys q. lookup q v when u = t  v)"
    proof (intro sum.mono_neutral_cong_left ballI)
      fix v
      assume "v  keys q - {x  keys q. component_of_term x = component_of_term u}"
      hence "u  t  v" by (auto simp: component_of_term_splus)
      thus "(lookup q v when u = t  v) = 0" by simp
    next
      fix v
      assume "v  {x  keys q. component_of_term x = component_of_term u}"
      hence eq[symmetric]: "component_of_term v = component_of_term u" by simp
      have "u = t  v  pp_of_term u = t + pp_of_term v"
      proof
        assume "pp_of_term u = t + pp_of_term v"
        hence "pp_of_term u = pp_of_term (t  v)" by (simp only: pp_of_term_splus)
        moreover have "component_of_term u = component_of_term (t  v)"
          by (simp only: eq component_of_term_splus)
        ultimately show "u = t  v" by (metis term_of_pair_pair)
      qed (simp add: pp_of_term_splus)
      thus "?f t (pp_of_term v) = (lookup q v when u = t  v)"
        by (simp add: lookup_proj_poly eq term_of_pair_pair)
    qed auto
    finally show "lookup p t * (Sum_any (?f t)) = lookup p t * (vkeys q. lookup q v when u = t  v)"
      by (simp only:)
  qed
  finally show ?thesis .
qed

lemma proj_mult_scalar [term_simps]: "proj_poly k (p  q) = p * (proj_poly k q)"
  unfolding mult_scalar_def by (rule proj_lift_poly_fun_homogenous, simp)

lemma mult_scalar_zero_left [simp]: "0  p = 0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps)

lemma mult_scalar_zero_right [simp]: "p  0 = 0"
  by (rule poly_mapping_eqI_proj, simp add: term_simps)

lemma mult_scalar_one [simp]: "(1::_ 0 'b::semiring_1)  p = p"
  by (rule poly_mapping_eqI_proj, simp add: term_simps)

lemma mult_scalar_assoc [ac_simps]: "(p * q)  r = p  (q  r)"
  by (rule poly_mapping_eqI_proj, simp add: ac_simps term_simps)

lemma mult_scalar_distrib_right [algebra_simps]: "(p + q)  r = p  r + q  r"
  by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)

lemma mult_scalar_distrib_left [algebra_simps]: "r  (p + q) = r  p + r  q"
  by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)

lemma mult_scalar_minus_mult_left [simp]: "(- p)  q = - (p  q)"
  by (rule sym, rule minus_unique, simp add: mult_scalar_distrib_right[symmetric])

lemma mult_scalar_minus_mult_right [simp]: "p  (- q) = - (p  q)"
  by (rule sym, rule minus_unique, simp add: mult_scalar_distrib_left [symmetric])

lemma minus_mult_scalar_minus [simp]: "(- p)  (- q) = p  q"
  by simp

lemma minus_mult_scalar_commute: "(- p)  q = p  (- q)"
  by simp

lemma mult_scalar_right_diff_distrib [algebra_simps]: "r  (p - q) = r  p - r  q"
  for r::"_ 0 'b::ring"
  using mult_scalar_distrib_left [of r p "- q"] by simp

lemma mult_scalar_left_diff_distrib [algebra_simps]: "(p - q)  r = p  r - q  r"
  for p::"_ 0 'b::ring"
  using mult_scalar_distrib_right [of p "- q" r] by simp

lemma sum_mult_scalar_distrib_left: "r  (sum f A) = (aA. r  f a)"
  by (induct A rule: infinite_finite_induct, simp_all add: algebra_simps)

lemma sum_mult_scalar_distrib_right: "(sum f A)  v = (aA. f a  v)"
  by (induct A rule: infinite_finite_induct, simp_all add: algebra_simps)

lemma mult_scalar_monomial_monomial: "(monomial c t)  (monomial d v) = monomial (c * d) (t  v)"
  by (rule poly_mapping_eqI_proj, simp add: proj_monomial mult_single when_def term_simps)

lemma mult_scalar_monomial: "(monomial c t)  p = monom_mult c t p"
  by (rule poly_mapping_eqI_proj, rule poly_mapping_eqI,
      auto simp add: lookup_times_monomial_left lookup_proj_poly lookup_monom_mult when_def
        adds_pp_def sminus_def term_simps)

lemma mult_scalar_rec_left: "p  q = monom_mult (lookup p t) t q + (except p {t})  q"
proof -
  from plus_except[of p t] have "p  q = (monomial (lookup p t) t + except p {t})  q" by simp
  also have "... = monomial (lookup p t) t  q + except p {t}  q" by (simp only: algebra_simps)
  finally show ?thesis by (simp only: mult_scalar_monomial)
qed

lemma mult_scalar_rec_right: "p  q = p  monomial (lookup q v) v + p  except q {v}"
proof -
  have "p  monomial (lookup q v) v + p  except q {v} = p  (monomial (lookup q v) v + except q {v})"
    by (simp only: mult_scalar_distrib_left)
  also have "... = p  q" by (simp only: plus_except[of q v, symmetric])
  finally show ?thesis by simp
qed

lemma in_keys_mult_scalarE:
  assumes "v  keys (p  q)"
  obtains t u where "t  keys p" and "u  keys q" and "v = t  u"
proof -
  from assms have "0  lookup (p  q) v" by (simp add: in_keys_iff)
  also have "lookup (p  q) v = lookup (p * (proj_poly (component_of_term v) q)) (pp_of_term v)"
    by (fact lookup_mult_scalar)
  finally have "pp_of_term v  keys (p * proj_poly (component_of_term v) q)" by (simp add: in_keys_iff)
  from this keys_mult have "pp_of_term v  {t + s |t s. t  keys p  s  keys (proj_poly (component_of_term v) q)}" ..
  then obtain t s where "t  keys p" and *: "s  keys (proj_poly (component_of_term v) q)"
    and eq: "pp_of_term v = t + s" by fastforce
  note this(1)
  moreover from * have "term_of_pair (s, component_of_term v)  keys q"
    by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
  moreover have "v = t  term_of_pair (s, component_of_term v)"
    by (simp add: splus_def eq[symmetric] term_simps)
  ultimately show ?thesis ..
qed

lemma lookup_mult_scalar_monomial_right:
  "lookup (p  monomial c v) u = (lookup p (pp_of_term u - pp_of_term v) * c when v addst u)"
proof -
  have eq1: "lookup (p * (monomial c (pp_of_term v) when component_of_term v = component_of_term u)) (pp_of_term u) =
             (lookup (p * (monomial c (pp_of_term v))) (pp_of_term u) when component_of_term v = component_of_term u)"
    by (rule when_distrib, simp)
  show ?thesis
    by (simp add: lookup_mult_scalar eq1 proj_monomial lookup_times_monomial_right when_when
        adds_term_def lookup_proj_poly conj_commute)
qed

lemma lookup_mult_scalar_monomial_right_plus: "lookup (p  monomial c v) (t  v) = lookup p t * c"
  by (simp add: lookup_mult_scalar_monomial_right term_simps)

lemma keys_mult_scalar_monomial_right_subset: "keys (p  monomial c v)  (λt. t  v) ` keys p"
proof
  fix u
  assume "u  keys (p  monomial c v)"
  then obtain t w where "t  keys p" and "w  keys (monomial c v)" and "u = t  w"
    by (rule in_keys_mult_scalarE)
  from this(2) have "w = v" by (metis empty_iff insert_iff keys_single)
  from t  keys p show "u  (λt. t  v) ` keys p" unfolding u = t  w w = v by fastforce
qed

lemma keys_mult_scalar_monomial_right:
  assumes "c  (0::'b::semiring_no_zero_divisors)"
  shows "keys (p  monomial c v) = (λt. t  v) ` keys p"
proof
  show "(λt. t  v) ` keys p  keys (p  monomial c v)"
  proof
    fix u
    assume "u  (λt. t  v) ` keys p"
    then obtain t where "t  keys p" and "u = t  v" ..
    have "lookup (p  monomial c v) (t  v) = lookup p t * c"
      by (fact lookup_mult_scalar_monomial_right_plus)
    also from t  keys p assms have "...  0" by (simp add: in_keys_iff)
    finally show "u  keys (p  monomial c v)" by (simp add: in_keys_iff u = t  v)
  qed
qed (fact keys_mult_scalar_monomial_right_subset)

end (* term_powerprod *)

subsection ‹Sums and Products›

lemma sum_poly_mapping_eq_zeroI:
  assumes "p ` A  {0}"
  shows "sum p A = (0::(_ 0 'b::comm_monoid_add))"
proof (rule ccontr)
  assume "sum p A  0"
  then obtain a where "a  A" and "p a  0"
    by (rule comm_monoid_add_class.sum.not_neutral_contains_not_neutral)
  with assms show False by auto
qed

lemma lookup_sum_list: "lookup (sum_list ps) a = sum_list (map (λp. lookup p a) ps)"
proof (induct ps)
  case Nil
  show ?case by simp
next
  case (Cons p ps)
  thus ?case by (simp add: lookup_add)
qed

text ‹Legacy:›
lemmas keys_sum_subset = Poly_Mapping.keys_sum

lemma keys_sum_list_subset: "keys (sum_list ps)  Keys (set ps)"
proof (induct ps)
  case Nil
  show ?case by simp
next
  case (Cons p ps)
  have "keys (sum_list (p # ps)) = keys (p + sum_list ps)" by simp
  also have "  keys p  keys (sum_list ps)" by (fact Poly_Mapping.keys_add)
  also from Cons have "  keys p  Keys (set ps)" by blast
  also have " = Keys (set (p # ps))" by (simp add: Keys_insert)
  finally show ?case .
qed

lemma keys_sum:
  assumes "finite A" and "a1 a2. a1  A  a2  A  a1  a2  keys (f a1)  keys (f a2) = {}"
  shows "keys (sum f A) = (aA. keys (f a))"
  using assms
proof (induct A)
  case empty
  show ?case by simp
next
  case (insert a A)
  have IH: "keys (sum f A) = (iA. keys (f i))" by (rule insert(3), rule insert.prems, simp_all)
  have "keys (sum f (insert a A)) = keys (f a)  keys (sum f A)"
  proof (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)], rule keys_add[symmetric])
    have "keys (f a)  keys (sum f A) = (iA. keys (f a)  keys (f i))"
      by (simp only: IH Int_UN_distrib)
    also have "... = {}"
    proof -
      have "i  A  keys (f a)  keys (f i) = {}" for i
      proof (rule insert.prems)
        assume "i  A"
        with insert(2) show "a  i" by blast
      qed simp_all
      thus ?thesis by simp
    qed
    finally show "keys (f a)  keys (sum f A) = {}" .
  qed
  also have "... = (ainsert a A. keys (f a))" by (simp add: IH)
  finally show ?case .
qed

lemma poly_mapping_sum_monomials: "(akeys p. monomial (lookup p a) a) = p"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by simp
next
  case step: (2 p c t)
  from step(2) have "lookup p t = 0" by (simp add: in_keys_iff)
  have *: "keys (monomial c t + p) = insert t (keys p)"
  proof -
    from step(1) have a: "keys (monomial c t) = {t}" by simp
    with step(2) have "keys (monomial c t)  keys p = {}" by simp
    hence "keys (monomial c t + p) = {t}  keys p" by (simp only: a keys_plus_eqI)
    thus ?thesis by simp
  qed
  have **: "(takeys p. monomial ((c when t = ta) + lookup p ta) ta) = (takeys p. monomial (lookup p ta) ta)"
  proof (rule comm_monoid_add_class.sum.cong, rule refl)
    fix s
    assume "s  keys p"
    with step(2) have "t  s" by auto
    thus "monomial ((c when t = s) + lookup p s) s = monomial (lookup p s) s" by simp
  qed
    show ?case by (simp only: * comm_monoid_add_class.sum.insert[OF finite_keys step(2)],
                   simp add: lookup_add lookup_single ‹lookup p t = 0 ** step(3))
  qed

lemma monomial_sum: "monomial (sum f C) a = (cC. monomial (f c) a)"
  by (rule fun_sum_commute, simp_all add: single_add)

lemma monomial_Sum_any:
  assumes "finite {c. f c  0}"
  shows "monomial (Sum_any f) a = (c. monomial (f c) a)"
proof -
  have "{c. monomial (f c) a  0}  {c. f c  0}" by (rule, auto)
  with assms show ?thesis
    by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monomial_sum)
qed

context term_powerprod
begin

lemma proj_sum: "proj_poly k (sum f A) = (aA. proj_poly k (f a))"
  using proj_zero proj_plus by (rule fun_sum_commute)

lemma proj_sum_list: "proj_poly k (sum_list xs) = sum_list (map (proj_poly k) xs)"
  using proj_zero proj_plus by (rule fun_sum_list_commute)

lemma mult_scalar_sum_monomials: "q  p = (tkeys q. monom_mult (lookup q t) t p)"
  by (rule poly_mapping_eqI_proj, simp add: proj_sum mult_scalar_monomial[symmetric]
      sum_distrib_right[symmetric] poly_mapping_sum_monomials term_simps)

lemma fun_mult_scalar_commute:
  assumes "f 0 = 0" and "x y. f (x + y) = f x + f y"
    and "c t. f (monom_mult c t p) = monom_mult c t (f p)"
  shows "f (q  p) = q  (f p)"
  by (simp add: mult_scalar_sum_monomials assms(3)[symmetric], rule fun_sum_commute, fact+)

lemma fun_mult_scalar_commute_canc:
  assumes "x y. f (x + y) = f x + f y" and "c t. f (monom_mult c t p) = monom_mult c t (f p)"
  shows "f (q  p) = q  (f (p::'t 0 'b::{semiring_0,cancel_comm_monoid_add}))"
  by (simp add: mult_scalar_sum_monomials assms(2)[symmetric], rule fun_sum_commute_canc, fact)

lemma monom_mult_sum_left: "monom_mult (sum f C) t p = (cC. monom_mult (f c) t p)"
  by (rule fun_sum_commute, simp_all add: monom_mult_dist_left)

lemma monom_mult_sum_right: "monom_mult c t (sum f P) = (pP. monom_mult c t (f p))"
  by (rule fun_sum_commute, simp_all add: monom_mult_dist_right)

lemma monom_mult_Sum_any_left:
  assumes "finite {c. f c  0}"
  shows "monom_mult (Sum_any f) t p = (c. monom_mult (f c) t p)"
proof -
  have "{c. monom_mult (f c) t p  0}  {c. f c  0}" by (rule, auto)
  with assms show ?thesis
    by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monom_mult_sum_left)
qed

lemma monom_mult_Sum_any_right:
  assumes "finite {p. f p  0}"
  shows "monom_mult c t (Sum_any f) = (p. monom_mult c t (f p))"
proof -
  have "{p. monom_mult c t (f p)  0}  {p. f p  0}" by (rule, auto)
  with assms show ?thesis
    by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monom_mult_sum_right)
qed

lemma monomial_prod_sum: "monomial (prod c I) (sum a I) = (iI. monomial (c i) (a i))"
proof (cases "finite I")
  case True
  thus ?thesis
  proof (induct I)
    case empty
    show ?case by simp
  next
    case (insert i I)
    show ?case
      by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)]
         comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] insert(3) mult_single[symmetric])
  qed
next
  case False
  thus ?thesis by simp
qed

subsection ‹Submodules›

sublocale pmdl: module mult_scalar
  apply standard
  subgoal by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus)
  subgoal by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus)
  subgoal by (rule poly_mapping_eqI_proj, simp add: ac_simps)
  subgoal by (rule poly_mapping_eqI_proj, simp)
  done

lemmas [simp del] = pmdl.scale_one pmdl.scale_zero_left pmdl.scale_zero_right pmdl.scale_scale
  pmdl.scale_minus_left pmdl.scale_minus_right pmdl.span_eq_iff

lemmas [algebra_simps del] = pmdl.scale_left_distrib pmdl.scale_right_distrib
  pmdl.scale_left_diff_distrib pmdl.scale_right_diff_distrib

abbreviation "pmdl  pmdl.span"

lemma pmdl_closed_monom_mult:
  assumes "p  pmdl B"
  shows "monom_mult c t p  pmdl B"
  unfolding mult_scalar_monomial[symmetric] using assms by (rule pmdl.span_scale)

lemma monom_mult_in_pmdl: "b  B  monom_mult c t b  pmdl B"
  by (intro pmdl_closed_monom_mult pmdl.span_base)

lemma pmdl_induct [consumes 1, case_names module_0 module_plus]:
  assumes "p  pmdl B" and "P 0"
    and "a p c t. a  pmdl B  P a  p  B  c  0  P (a + monom_mult c t p)"
  shows "P p"
  using assms(1)
proof (induct p rule: pmdl.span_induct')
  case base
  from assms(2) show ?case .
next
  case (step a q b)
  from this(1) this(2) show ?case
  proof (induct q arbitrary: a rule: poly_mapping_except_induct)
    case 1
    thus ?case by simp
  next
    case step: (2 q0 t)
    from this(4) step(5) b  B have "P (a + monomial (lookup q0 t) t  b)"
      unfolding mult_scalar_monomial
    proof (rule assms(3))
      from step(2) show "lookup q0 t  0" by (simp add: in_keys_iff)
    qed
    with _ have "P ((a + monomial (lookup q0 t) t  b) + except q0 {t}  b)"
    proof (rule step(3))
      from b  B have "b  pmdl B" by (rule pmdl.span_base)
      hence "monomial (lookup q0 t) t  b  pmdl B" by (rule pmdl.span_scale)
      with step(4) show "a + monomial (lookup q0 t) t  b  pmdl B" by (rule pmdl.span_add)
    qed
    hence "P (a + (monomial (lookup q0 t) t + except q0 {t})  b)" by (simp add: algebra_simps)
    thus ?case by (simp only: plus_except[of q0 t, symmetric])
  qed
qed

lemma components_pmdl: "component_of_term ` Keys (pmdl B) = component_of_term ` Keys B"
proof
  show "component_of_term ` Keys (pmdl B)  component_of_term ` Keys B"
  proof
    fix k
    assume "k  component_of_term ` Keys (pmdl B)"
    then obtain v where "v  Keys (pmdl B)" and "k = component_of_term v" ..
    from this(1) obtain b where "b  pmdl B" and "v  keys b" by (rule in_KeysE)
    thus "k  component_of_term ` Keys B"
    proof (induct b rule: pmdl_induct)
      case module_0
      thus ?case by simp
    next
      case ind: (module_plus a p c t)
      from ind.prems Poly_Mapping.keys_add have "v  keys a  keys (monom_mult c t p)" ..
      thus ?case
      proof
        assume "v  keys a"
        thus ?thesis by (rule ind.hyps(2))
      next
        assume "v  keys (monom_mult c t p)"
        from this keys_monom_mult_subset have "v  (⊕) t ` keys p" ..
        then obtain u where "u  keys p" and "v = t  u" ..
        have "k = component_of_term u" by (simp add: k = component_of_term v v = t  u term_simps)
        moreover from u  keys p ind.hyps(3) have "u  Keys B" by (rule in_KeysI)
        ultimately show ?thesis ..
      qed
    qed
  qed
next
  show "component_of_term ` Keys B  component_of_term ` Keys (pmdl B)"
    by (rule image_mono, rule Keys_mono, fact pmdl.span_superset)
qed

lemma pmdl_idI:
  assumes "0  B" and "b1 b2. b1  B  b2  B  b1 + b2  B"
    and "c t b. b  B  monom_mult c t b  B"
  shows "pmdl B = B"
proof
  show "pmdl B  B"
  proof
    fix p
    assume "p  pmdl B"
    thus "p  B"
    proof (induct p rule: pmdl_induct)
      case module_0
      show ?case by (fact assms(1))
    next
      case step: (module_plus a b c t)
      from step(2) show ?case
      proof (rule assms(2))
        from step(3) show "monom_mult c t b  B" by (rule assms(3))
      qed
    qed
  qed
qed (fact pmdl.span_superset)

definition full_pmdl :: "'k set  ('t 0 'b::zero) set"
  where "full_pmdl K = {p. component_of_term ` keys p  K}"

definition is_full_pmdl :: "('t 0 'b::comm_ring_1) set  bool"
  where "is_full_pmdl B  (p. component_of_term ` keys p  component_of_term ` Keys B  p  pmdl B)"

lemma full_pmdl_iff: "p  full_pmdl K  component_of_term ` keys p  K"
  by (simp add: full_pmdl_def)

lemma full_pmdlI:
  assumes "v. v  keys p  component_of_term v  K"
  shows "p  full_pmdl K"
  using assms by (auto simp add: full_pmdl_iff)

lemma full_pmdlD:
  assumes "p  full_pmdl K" and "v  keys p"
  shows "component_of_term v  K"
  using assms by (auto simp add: full_pmdl_iff)

lemma full_pmdl_empty: "full_pmdl {} = {0}"
  by (simp add: full_pmdl_def)

lemma full_pmdl_UNIV: "full_pmdl UNIV = UNIV"
  by (simp add: full_pmdl_def)

lemma zero_in_full_pmdl: "0  full_pmdl K"
  by (simp add: full_pmdl_iff)

lemma full_pmdl_closed_plus:
  assumes "p  full_pmdl K" and "q  full_pmdl K"
  shows "p + q  full_pmdl K"
proof (rule full_pmdlI)
  fix v
  assume "v  keys (p + q)"
  also have "...  keys p  keys q" by (fact Poly_Mapping.keys_add)
  finally show "component_of_term v  K"
  proof
    assume "v  keys p"
    with assms(1) show ?thesis by (rule full_pmdlD)
  next
    assume "v  keys q"
    with assms(2) show ?thesis by (rule full_pmdlD)
  qed
qed

lemma full_pmdl_closed_monom_mult:
  assumes "p  full_pmdl K"
  shows "monom_mult c t p  full_pmdl K"
proof (rule full_pmdlI)
  fix v
  assume "v  keys (monom_mult c t p)"
  also have "...  (⊕) t ` keys p" by (fact keys_monom_mult_subset)
  finally obtain u where "u  keys p" and v: "v = t  u" ..
  have "component_of_term v = component_of_term u" by (simp add: v term_simps)
  also from assms u  keys p have "...  K" by (rule full_pmdlD)
  finally show "component_of_term v  K" .
qed

lemma pmdl_full_pmdl: "pmdl (full_pmdl K) = full_pmdl K"
  using zero_in_full_pmdl full_pmdl_closed_plus full_pmdl_closed_monom_mult by (rule pmdl_idI)

lemma components_full_pmdl_subset:
  "component_of_term ` Keys ((full_pmdl K)::('t 0 'b::zero) set)  K" (is "?l  _")
proof
  let ?M = "(full_pmdl K)::('t 0 'b) set"
  fix k
  assume "k  ?l"
  then obtain v where "v  Keys ?M" and k: "k = component_of_term v" ..
  from this(1) obtain p where "p  ?M" and "v  keys p" by (rule in_KeysE)
  thus "k  K" unfolding k by (rule full_pmdlD)
qed

lemma components_full_pmdl:
  "component_of_term ` Keys ((full_pmdl K)::('t 0 'b::zero_neq_one) set) = K" (is "?l = _")
proof
  let ?M = "(full_pmdl K)::('t 0 'b) set"
  show "K  ?l"
  proof
    fix k
    assume "k  K"
    hence "monomial 1 (term_of_pair (0, k))  ?M" by (simp add: full_pmdl_iff term_simps)
    hence "keys (monomial (1::'b) (term_of_pair (0, k)))  Keys ?M" by (rule keys_subset_Keys)
    hence "term_of_pair (0, k)  Keys ?M" by simp
    hence "component_of_term (term_of_pair (0, k))  component_of_term ` Keys ?M" by (rule imageI)
    thus "k  ?l" by (simp only: component_of_term_of_pair)
  qed
qed (fact components_full_pmdl_subset)

lemma is_full_pmdlI:
  assumes "p. component_of_term ` keys p  component_of_term ` Keys B  p  pmdl B"
  shows "is_full_pmdl B"
  unfolding is_full_pmdl_def using assms by blast

lemma is_full_pmdlD:
  assumes "is_full_pmdl B" and "component_of_term ` keys p  component_of_term ` Keys B"
  shows "p  pmdl B"
  using assms unfolding is_full_pmdl_def by blast

lemma is_full_pmdl_alt: "is_full_pmdl B  pmdl B = full_pmdl (component_of_term ` Keys B)"
proof -
  have "b  pmdl B  v  keys b  component_of_term v  component_of_term ` Keys B" for b v
    by (metis components_pmdl image_eqI in_KeysI)
  thus ?thesis by (auto simp add: is_full_pmdl_def full_pmdl_def)
qed

lemma is_full_pmdl_pmdl: "is_full_pmdl (pmdl B)  is_full_pmdl B"
  by (simp only: is_full_pmdl_def pmdl.span_span components_pmdl)

lemma is_full_pmdl_subset:
  assumes "is_full_pmdl B1" and "is_full_pmdl B2"
    and "component_of_term ` Keys B1  component_of_term ` Keys B2"
  shows "pmdl B1  pmdl B2"
proof
  fix p
  assume "p  pmdl B1"
  from assms(2) show "p  pmdl B2"
  proof (rule is_full_pmdlD)
    have "component_of_term ` keys p  component_of_term ` Keys (pmdl B1)"
      by (rule image_mono, rule keys_subset_Keys, fact)
    also have "... = component_of_term ` Keys B1" by (fact components_pmdl)
    finally show "component_of_term ` keys p  component_of_term ` Keys B2" using assms(3)
      by (rule subset_trans)
  qed
qed

lemma is_full_pmdl_eq:
  assumes "is_full_pmdl B1" and "is_full_pmdl B2"
    and "component_of_term ` Keys B1 = component_of_term ` Keys B2"
  shows "pmdl B1 = pmdl B2"
proof
  have "component_of_term ` Keys B1  component_of_term ` Keys B2" by (simp add: assms(3))
  with assms(1, 2) show "pmdl B1  pmdl B2" by (rule is_full_pmdl_subset)
next
  have "component_of_term ` Keys B2  component_of_term ` Keys B1" by (simp add: assms(3))
  with assms(2, 1) show "pmdl B2  pmdl B1" by (rule is_full_pmdl_subset)
qed

end (* term_powerprod *)

definition map_scale :: "'b  ('a 0 'b)  ('a 0 'b::mult_zero)" (infixr "" 71)
  where "map_scale c = Poly_Mapping.map ((*) c)"

text ‹If the polynomial mapping p› is interpreted as a power-product, then @{term "c  p"}
  corresponds to exponentiation; if it is interpreted as a (vector-) polynomial, then @{term "c  p"}
  corresponds to multiplication by scalar from the coefficient type.›

lemma lookup_map_scale [simp]: "lookup (c  p) = (λx. c * lookup p x)"
  by (auto simp: map_scale_def map.rep_eq when_def)

lemma map_scale_single [simp]: "k  Poly_Mapping.single x l = Poly_Mapping.single x (k * l)"
  by (simp add: map_scale_def)

lemma map_scale_zero_left [simp]: "0  t = 0"
  by (rule poly_mapping_eqI) simp

lemma map_scale_zero_right [simp]: "k  0 = 0"
  by (rule poly_mapping_eqI) simp

lemma map_scale_eq_0_iff: "c  t = 0  ((c::_::semiring_no_zero_divisors) = 0  t = 0)"
  by (metis aux lookup_map_scale mult_eq_0_iff)

lemma keys_map_scale_subset: "keys (k  t)  keys t"
  by (metis in_keys_iff lookup_map_scale mult_zero_right subsetI)

lemma keys_map_scale: "keys ((k::'b::semiring_no_zero_divisors)  t) = (if k = 0 then {} else keys t)"
proof (split if_split, intro conjI impI)
  assume "k = 0"
  thus "keys (k  t) = {}" by simp
next
  assume "k  0"
  show "keys (k  t) = keys t"
  proof
    show "keys t  keys (k  t)" by rule (simp add: k  0 flip: lookup_not_eq_zero_eq_in_keys)
  qed (fact keys_map_scale_subset)
qed

lemma map_scale_one_left [simp]: "(1::'b::{mult_zero,monoid_mult})  t = t"
  by (rule poly_mapping_eqI) simp

lemma map_scale_assoc [ac_simps]: "c  d  t = (c * d)  (t::_ 0 _::{semigroup_mult,zero})"
  by (rule poly_mapping_eqI) (simp add: ac_simps)

lemma map_scale_distrib_left [algebra_simps]: "(k::'b::semiring_0)  (s + t) = k  s + k  t"
  by (rule poly_mapping_eqI) (simp add: lookup_add distrib_left)

lemma map_scale_distrib_right [algebra_simps]: "(k + (l::'b::semiring_0))  t = k  t + l  t"
  by (rule poly_mapping_eqI) (simp add: lookup_add distrib_right)

lemma map_scale_Suc: "(Suc k)  t = k  t + t"
  by (rule poly_mapping_eqI) (simp add: lookup_add distrib_right)

lemma map_scale_uminus_left: "(- k::'b::ring)  p = - (k  p)"
  by (rule poly_mapping_eqI) auto

lemma map_scale_uminus_right: "(k::'b::ring)  (- p) = - (k  p)"
  by (rule poly_mapping_eqI) auto

lemma map_scale_uminus_uminus [simp]: "(- k::'b::ring)  (- p) = k  p"
  by (simp add: map_scale_uminus_left map_scale_uminus_right)

lemma map_scale_minus_distrib_left [algebra_simps]:
  "(k::'b::comm_semiring_1_cancel)  (p - q) = k  p - k  q"
  by (rule poly_mapping_eqI) (auto simp add: lookup_minus right_diff_distrib')

lemma map_scale_minus_distrib_right [algebra_simps]:
  "(k - (l::'b::comm_semiring_1_cancel))  f = k  f - l  f"
  by (rule poly_mapping_eqI) (auto simp add: lookup_minus left_diff_distrib')

lemma map_scale_sum_distrib_left: "(k::'b::semiring_0)  (sum f A) = (aA. k  f a)"
  by (induct A rule: infinite_finite_induct) (simp_all add: map_scale_distrib_left)

lemma map_scale_sum_distrib_right: "(sum (f::_  'b::semiring_0) A)  p = (aA. f a  p)"
  by (induct A rule: infinite_finite_induct) (simp_all add: map_scale_distrib_right)

lemma deg_pm_map_scale: "deg_pm (k  t) = (k::'b::semiring_0) * deg_pm t"
proof -
  from keys_map_scale_subset finite_keys have "deg_pm (k  t) = sum (lookup (k  t)) (keys t)"
    by (rule deg_pm_superset)
  also have " = k * sum (lookup t) (keys t)" by (simp add: sum_distrib_left)
  also from subset_refl finite_keys have "sum (lookup t) (keys t) = deg_pm t"
    by (rule deg_pm_superset[symmetric])
  finally show ?thesis .
qed

interpretation phull: module map_scale
  apply standard
  subgoal by (fact map_scale_distrib_left)
  subgoal by (fact map_scale_distrib_right)
  subgoal by (fact map_scale_assoc)
  subgoal by (fact map_scale_one_left)
  done

text ‹Since the following lemmas are proved for more general ring-types above, we do not need to
  have them in the simpset.›

lemmas [simp del] = phull.scale_one phull.scale_zero_left phull.scale_zero_right phull.scale_scale
  phull.scale_minus_left phull.scale_minus_right phull.span_eq_iff

lemmas [algebra_simps del] = phull.scale_left_distrib phull.scale_right_distrib
  phull.scale_left_diff_distrib phull.scale_right_diff_distrib

abbreviation "phull  phull.span"

text @{term ‹phull B} is a module over the coefficient ring @{typ 'b}, whereas
  @{term ‹term_powerprod.pmdl B} is a module over the (scalar) polynomial ring @{typ 'a 0 'b}.
  Nevertheless, both modules can be sets of @{emph ‹vector-polynomials›} of type @{typ 't 0 'b}.›

context term_powerprod
begin

lemma map_scale_eq_monom_mult: "c  p = monom_mult c 0 p"
  by (rule poly_mapping_eqI) (simp only: lookup_map_scale lookup_monom_mult_zero)

lemma map_scale_eq_mult_scalar: "c  p = monomial c 0  p"
  by (simp only: map_scale_eq_monom_mult mult_scalar_monomial)

lemma phull_closed_mult_scalar: "p  phull B  monomial c 0  p  phull B"
  unfolding map_scale_eq_mult_scalar[symmetric] by (rule phull.span_scale)

lemma mult_scalar_in_phull: "b  B  monomial c 0  b  phull B"
  by (intro phull_closed_mult_scalar phull.span_base)

lemma phull_subset_module: "phull B  pmdl B"
proof
  fix p
  assume "p  phull B"
  thus "p  pmdl B"
  proof (induct p rule: phull.span_induct')
    case base
    show ?case by (fact pmdl.span_zero)
  next
    case (step a c p)
    from step(3) have "p  pmdl B" by (rule pmdl.span_base)
    hence "c  p  pmdl B" unfolding map_scale_eq_monom_mult by (rule pmdl_closed_monom_mult)
    with step(2) show ?case by (rule pmdl.span_add)
  qed
qed

lemma components_phull: "component_of_term ` Keys (phull B) = component_of_term ` Keys B"
proof
  have "component_of_term ` Keys (phull B)  component_of_term ` Keys (pmdl B)"
    by (rule image_mono, rule Keys_mono, fact phull_subset_module)
  also have "... = component_of_term ` Keys B" by (fact components_pmdl)
  finally show "component_of_term ` Keys (phull B)  component_of_term ` Keys B" .
next
  show "component_of_term ` Keys B  component_of_term ` Keys (phull B)"
    by (rule image_mono, rule Keys_mono, fact phull.span_superset)
qed

end

subsection ‹Interpretations›

subsubsection ‹Isomorphism between @{typ 'a} and @{typ "'a × unit"}

definition to_pair_unit :: "'a  ('a × unit)"
  where "to_pair_unit x = (x, ())"

lemma fst_to_pair_unit: "fst (to_pair_unit x) = x"
  by (simp add: to_pair_unit_def)

lemma to_pair_unit_fst: "to_pair_unit (fst x) = (x::_ × unit)"
  by (metis (full_types) old.unit.exhaust prod.collapse to_pair_unit_def)

interpretation punit: term_powerprod to_pair_unit fst
  apply standard
  subgoal by (fact fst_to_pair_unit)
  subgoal by (fact to_pair_unit_fst)
  done

text ‹For technical reasons it seems to be better not to put the following lemmas as rewrite-rules
  of interpretation punit›.›

lemma punit_pp_of_term [simp]: "punit.pp_of_term = (λx. x)"
  by (rule, simp add: punit.pp_of_term_def punit.term_pair)

lemma punit_component_of_term [simp]: "punit.component_of_term = (λ_. ())"
  by (rule, simp add: punit.component_of_term_def)

lemma punit_splus [simp]: "punit.splus = (+)"
  by (rule, rule, simp add: punit.splus_def)

lemma punit_sminus [simp]: "punit.sminus = (-)"
  by (rule, rule, simp add: punit.sminus_def)

lemma punit_adds_pp [simp]: "punit.adds_pp = (adds)"
  by (rule, rule, simp add: punit.adds_pp_def)

lemma punit_adds_term [simp]: "punit.adds_term = (adds)"
  by (rule, rule, simp add: punit.adds_term_def)

lemma punit_proj_poly [simp]: "punit.proj_poly = (λ_. id)"
  by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_proj_poly)

lemma punit_mult_vec [simp]: "punit.mult_vec = (*)"
  by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_mult_vec)

lemma punit_mult_scalar [simp]: "punit.mult_scalar = (*)"
  by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_mult_scalar)

context term_powerprod
begin

lemma proj_monom_mult: "proj_poly k (monom_mult c t p) = punit.monom_mult c t (proj_poly k p)"
  by (metis mult_scalar_monomial proj_mult_scalar punit.mult_scalar_monomial punit_mult_scalar)

lemma mult_scalar_monom_mult: "(punit.monom_mult c t p)  q = monom_mult c t (p  q)"
  by (simp add: punit.mult_scalar_monomial[symmetric] mult_scalar_assoc mult_scalar_monomial)

end (* term_powerprod *)

subsubsection ‹Interpretation of @{locale term_powerprod} by @{typ "'a × 'k"}

interpretation pprod: term_powerprod "(λx::'a::comm_powerprod × 'k::linorder. x)" "λx. x"
  by (standard, simp)

lemma pprod_pp_of_term [simp]: "pprod.pp_of_term = fst"
  by (rule, simp add: pprod.pp_of_term_def)

lemma pprod_component_of_term [simp]: "pprod.component_of_term = snd"
  by (rule, simp add: pprod.component_of_term_def)

subsubsection ‹Simplifier Setup›

text ‹There is no reason to keep the interpreted theorems as simplification rules.›

lemmas [term_simps del] = term_simps

lemmas times_monomial_monomial = punit.mult_scalar_monomial_monomial[simplified]
lemmas times_monomial_left = punit.mult_scalar_monomial[simplified]
lemmas times_rec_left = punit.mult_scalar_rec_left[simplified]
lemmas times_rec_right = punit.mult_scalar_rec_right[simplified]
lemmas in_keys_timesE = punit.in_keys_mult_scalarE[simplified]
lemmas punit_monom_mult_monomial = punit.monom_mult_monomial[simplified]
lemmas lookup_times = punit.lookup_mult_scalar_explicit[simplified]
lemmas map_scale_eq_times = punit.map_scale_eq_mult_scalar[simplified]

end (* theory *)

Theory MPoly_Type_Class_Ordered

(* Author: Fabian Immler, Alexander Maletzky *)

section ‹Type-Class-Multivariate Polynomials in Ordered Terms›

theory MPoly_Type_Class_Ordered
  imports MPoly_Type_Class
begin

class the_min = linorder +
  fixes the_min::'a
  assumes the_min_min: "the_min  x"

text ‹Type class @{class the_min} guarantees that a least element exists. Instances of @{class the_min}
  should provide @{emph ‹computable›} definitions of that element.›

instantiation nat :: the_min
begin
  definition "the_min_nat = (0::nat)"
  instance by (standard, simp add: the_min_nat_def)
end

instantiation unit :: the_min
begin
  definition "the_min_unit = ()"
  instance by (standard, simp add: the_min_unit_def)
end

locale ordered_term =
    term_powerprod pair_of_term term_of_pair +
    ordered_powerprod ord ord_strict +
    ord_term_lin: linorder ord_term ord_term_strict
      for pair_of_term::"'t  ('a::comm_powerprod × 'k::{the_min,wellorder})"
      and term_of_pair::"('a × 'k)  't"
      and ord::"'a  'a  bool" (infixl "" 50)
      and ord_strict (infixl "" 50)
      and ord_term::"'t  't  bool" (infixl "t" 50)
      and ord_term_strict::"'t  't  bool" (infixl "t" 50) +
		assumes splus_mono: "v t w  t  v t t  w"
    assumes ord_termI: "pp_of_term v  pp_of_term w  component_of_term v  component_of_term w  v t w"
begin

abbreviation ord_term_conv (infixl "t" 50) where "ord_term_conv  (≼t)¯¯"
abbreviation ord_term_strict_conv (infixl "t" 50) where "ord_term_strict_conv  (≺t)¯¯"

text ‹The definition of @{locale ordered_term} only covers TOP and POT orderings. 
  These two types of orderings are the only interesting ones.›

definition "min_term  term_of_pair (0, the_min)"

lemma min_term_min: "min_term t v"
proof (rule ord_termI)
  show "pp_of_term min_term  pp_of_term v" by (simp add: min_term_def zero_min term_simps)
next
  show "component_of_term min_term  component_of_term v" by (simp add: min_term_def the_min_min term_simps)
qed

lemma splus_mono_strict:
  assumes "v t w"
  shows "t  v t t  w"
proof -
  from assms have "v t w" and "v  w" by simp_all
  from this(1) have "t  v t t  w" by (rule splus_mono)
  moreover from v  w have "t  v  t  w" by (simp add: term_simps)
  ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
qed

lemma splus_mono_left:
  assumes "s  t"
  shows "s  v t t  v"
proof (rule ord_termI, simp_all add: term_simps)
  from assms show "s + pp_of_term v  t + pp_of_term v" by (rule plus_monotone)
qed

lemma splus_mono_strict_left:
  assumes "s  t"
  shows "s  v t t  v"
proof -
  from assms have "s  t" and "s  t" by simp_all
  from this(1) have "s  v t t  v" by (rule splus_mono_left)
  moreover from s  t have "s  v  t  v" by (simp add: term_simps)
  ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
qed

lemma ord_term_canc:
  assumes "t  v t t  w"
  shows "v t w"
proof (rule ccontr)
  assume "¬ v t w"
  hence "w t v" by simp
  hence "t  w t t  v" by (rule splus_mono_strict)
  with assms show False by simp
qed

lemma ord_term_strict_canc:
  assumes "t  v t t  w"
  shows "v t w"
proof (rule ccontr)
  assume "¬ v t w"
  hence "w t v" by simp
  hence "t  w t t  v" by (rule splus_mono)
  with assms show False by simp
qed

lemma ord_term_canc_left:
  assumes "t  v t s  v"
  shows "t  s"
proof (rule ccontr)
  assume "¬ t  s"
  hence "s  t" by simp
  hence "s  v t t  v" by (rule splus_mono_strict_left)
  with assms show False by simp
qed

lemma ord_term_strict_canc_left:
  assumes "t  v t s  v"
  shows "t  s"
proof (rule ccontr)
  assume "¬ t  s"
  hence "s  t" by simp
  hence "s  v t t  v" by (rule splus_mono_left)
  with assms show False by simp
qed

lemma ord_adds_term:
  assumes "u addst v"
  shows "u t v"
proof -
  from assms have *: "component_of_term u  component_of_term v" and "pp_of_term u adds pp_of_term v"
    by (simp_all add: adds_term_def)
  from this(2) have "pp_of_term u  pp_of_term v" by (rule ord_adds)
  from this * show ?thesis by (rule ord_termI)
qed

end

subsection ‹Interpretations›

context ordered_powerprod
begin

subsubsection ‹Unit›

sublocale punit: ordered_term to_pair_unit fst "(≼)" "(≺)" "(≼)" "(≺)"
  apply standard
  subgoal by (simp, fact plus_monotone_left)
  subgoal by (simp only: punit_pp_of_term punit_component_of_term)
  done

lemma punit_min_term [simp]: "punit.min_term = 0"
  by (simp add: punit.min_term_def)

end

subsection ‹Definitions›

context ordered_term
begin

definition higher :: "('t 0 'b)  't  ('t 0 'b::zero)"
  where "higher p t = except p {s. s t t}"

definition lower :: "('t 0 'b)  't  ('t 0 'b::zero)"
  where "lower p t = except p {s. t t s}"

definition lt :: "('t 0 'b::zero)  't"
  where "lt p = (if p = 0 then min_term else ord_term_lin.Max (keys p))"

abbreviation "lp p  pp_of_term (lt p)"

definition lc :: "('t 0 'b::zero)  'b"
  where "lc p = lookup p (lt p)"

definition tt :: "('t 0 'b::zero)  't"
  where "tt p = (if p = 0 then min_term else ord_term_lin.Min (keys p))"

abbreviation "tp p  pp_of_term (tt p)"

definition tc :: "('t 0 'b::zero)  'b"
  where "tc p  lookup p (tt p)"

definition tail :: "('t 0 'b)  ('t 0 'b::zero)"
  where "tail p  lower p (lt p)"

subsection ‹Leading Term and Leading Coefficient: @{const lt} and @{const lc}

lemma lt_zero [simp]: "lt 0 = min_term"
  by (simp add: lt_def)

lemma lc_zero [simp]: "lc 0 = 0"
  by (simp add: lc_def)

lemma lt_uminus [simp]: "lt (- p) = lt p"
  by (simp add: lt_def keys_uminus)

lemma lc_uminus [simp]: "lc (- p) = - lc p"
  by (simp add: lc_def)

lemma lt_alt:
  assumes "p  0"
  shows "lt p = ord_term_lin.Max (keys p)"
  using assms unfolding lt_def by simp

lemma lt_max:
  assumes "lookup p v  0"
  shows "v t lt p"
proof -
  from assms have t_in: "v  keys p" by (simp add: in_keys_iff)
  hence "keys p  {}" by auto
  hence "p  0" using keys_zero by blast
  from lt_alt[OF this] ord_term_lin.Max_ge[OF finite_keys t_in] show ?thesis by simp
qed

lemma lt_eqI:
  assumes "lookup p v  0" and "u. lookup p u  0  u t v"
  shows "lt p = v"
proof -
  from assms(1) have "v  keys p" by (simp add: in_keys_iff)
  hence "keys p  {}" by auto
  hence "p  0"
    using keys_zero by blast
  have "u t v" if "u  keys p" for u
  proof -
    from that have "lookup p u  0" by (simp add: in_keys_iff)
    thus "u t v" by (rule assms(2))
  qed
  from lt_alt[OF p  0] ord_term_lin.Max_eqI[OF finite_keys this v  keys p] show ?thesis by simp
qed

lemma lt_less:
  assumes "p  0" and "u. v t u  lookup p u = 0"
  shows "lt p t v"
proof -
  from p  0 have "keys p  {}"
    by simp
  have "ukeys p. u t v"
  proof
    fix u::'t
    assume "u  keys p"
    hence "lookup p u  0" by (simp add: in_keys_iff)
    hence "¬ v t u" using assms(2)[of u] by auto
    thus "u t v" by simp
  qed
  with lt_alt[OF assms(1)] ord_term_lin.Max_less_iff[OF finite_keys ‹keys p  {}] show ?thesis by simp
qed

lemma lt_le:
  assumes "u. v t u  lookup p u = 0"
  shows "lt p t v"
proof (cases "p = 0")
  case True
  show ?thesis by (simp add: True min_term_min)
next
  case False
  hence "keys p  {}" by simp
  have "ukeys p. u t v"
  proof
    fix u::'t
    assume "u  keys p"
    hence "lookup p u  0" unfolding keys_def by simp
    hence "¬ v t u" using assms[of u] by auto
    thus "u t v" by simp
  qed
  with lt_alt[OF False] ord_term_lin.Max_le_iff[OF finite_keys[of p] ‹keys p  {}]
    show ?thesis by simp
qed

lemma lt_gr:
  assumes "lookup p s  0" and "t t s"
  shows "t t lt p"
  using assms lt_max ord_term_lin.order.strict_trans2 by blast

lemma lc_not_0:
  assumes "p  0"
  shows "lc p  0"
proof -
  from keys_zero assms have "keys p  {}" by auto
  from lt_alt[OF assms] ord_term_lin.Max_in[OF finite_keys this] show ?thesis by (simp add: in_keys_iff lc_def)
qed

lemma lc_eq_zero_iff: "lc p = 0  p = 0"
  using lc_not_0 lc_zero by blast

lemma lt_in_keys:
  assumes "p  0"
  shows "lt p  (keys p)"
  by (metis assms in_keys_iff lc_def lc_not_0)

lemma lt_monomial:
  "lt (monomial c t) = t" if "c  0"
  using that by (auto simp add: lt_def dest: monomial_0D)

lemma lc_monomial [simp]: "lc (monomial c t) = c"
proof (cases "c = 0")
  case True
  thus ?thesis by simp
next
  case False
  thus ?thesis by (simp add: lc_def lt_monomial)
qed
   
lemma lt_le_iff: "lt p t v  (u. v t u  lookup p u = 0)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (intro allI impI)
    fix u
    note ‹lt p t v
    also assume "v t u"
    finally have "lt p t u" .
    hence "¬ u t lt p" by simp
    with lt_max[of p u] show "lookup p u = 0" by blast
  qed
next
  assume ?R
  thus ?L using lt_le by auto
qed

lemma lt_plus_eqI:
  assumes "lt p t lt q"
  shows "lt (p + q) = lt q"
proof (cases "q = 0")
  case True
  with assms have "lt p t min_term" by (simp add: lt_def)
  with min_term_min[of "lt p"] show ?thesis by simp
next
  case False
  show ?thesis
  proof (intro lt_eqI)
    from lt_gr[of p "lt q" "lt p"] assms have "lookup p (lt q) = 0" by blast
    with lookup_add[of p q "lt q"] lc_not_0[OF False] show "lookup (p + q) (lt q)  0"
      unfolding lc_def by simp
  next
    fix u
    assume "lookup (p + q) u  0"
    show "u t lt q"
    proof (rule ccontr)
      assume "¬ u t lt q"
      hence qs: "lt q t u" by simp
      with assms have "lt p t u" by simp
      with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
      moreover from qs lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
      ultimately show False using ‹lookup (p + q) u  0 lookup_add[of p q u] by auto
    qed
  qed
qed

lemma lt_plus_eqI_2:
  assumes "lt q t lt p"
  shows "lt (p + q) = lt p"
proof (cases "p = 0")
  case True
  with assms have "lt q t min_term" by (simp add: lt_def)
  with min_term_min[of "lt q"] show ?thesis by simp
next
  case False
  show ?thesis
  proof (intro lt_eqI)
    from lt_gr[of q "lt p" "lt q"] assms have "lookup q (lt p) = 0" by blast
    with lookup_add[of p q "lt p"] lc_not_0[OF False] show "lookup (p + q) (lt p)  0"
      unfolding lc_def by simp
  next
    fix u
    assume "lookup (p + q) u  0"
    show "u t lt p"
    proof (rule ccontr)
      assume "¬ u t lt p"
      hence ps: "lt p t u" by simp
      with assms have "lt q t u" by simp
      with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
      also from ps lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
      ultimately show False using ‹lookup (p + q) u  0 lookup_add[of p q u] by auto
    qed
  qed
qed

lemma lt_plus_eqI_3:
  assumes "lt q = lt p" and "lc p + lc q  0"
  shows "lt (p + q) = lt (p::'t 0 'b::monoid_add)"
proof (rule lt_eqI)
  from assms(2) show "lookup (p + q) (lt p)  0" by (simp add: lookup_add lc_def assms(1))
next
  fix u
  assume "lookup (p + q) u  0"
  hence "lookup p u + lookup q u  0" by (simp add: lookup_add)
  hence "lookup p u  0  lookup q u  0" by auto
  thus "u t lt p"
  proof
    assume "lookup p u  0"
    thus ?thesis by (rule lt_max)
  next
    assume "lookup q u  0"
    hence "u t lt q" by (rule lt_max)
    thus ?thesis by (simp only: assms(1))
  qed
qed

lemma lt_plus_lessE:
  assumes "lt p t lt (p + q)"
  shows "lt p t lt q"
proof (rule ccontr)
  assume "¬ lt p t lt q"
  hence "lt p = lt q  lt q t lt p" by auto
  thus False
  proof
    assume lt_eq: "lt p = lt q"
    have "lt (p + q) t lt p"
    proof (rule lt_le)
      fix u
      assume "lt p t u"
      with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
      from ‹lt p t u have "lt q t u" using lt_eq by simp
      with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
      with ‹lookup p u = 0 show "lookup (p + q) u = 0" by (simp add: lookup_add)
    qed
    with assms show False by simp
  next
    assume "lt q t lt p"
    from lt_plus_eqI_2[OF this] assms show False by simp
  qed
qed

lemma lt_plus_lessE_2:
  assumes "lt q t lt (p + q)"
  shows "lt q t lt p"
proof (rule ccontr)
  assume "¬ lt q t lt p"
  hence "lt q = lt p  lt p t lt q" by auto
  thus False
  proof
    assume lt_eq: "lt q = lt p"
    have "lt (p + q) t lt q"
    proof (rule lt_le)
      fix u
      assume "lt q t u"
      with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
      from ‹lt q t u have "lt p t u" using lt_eq by simp
      with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
      with ‹lookup q u = 0 show "lookup (p + q) u = 0" by (simp add: lookup_add)
    qed
    with assms show False by simp
  next
    assume "lt p t lt q"
    from lt_plus_eqI[OF this] assms show False by simp
  qed
qed

lemma lt_plus_lessI':
  fixes p q :: "'t 0 'b::monoid_add"
  assumes "p + q  0" and lt_eq: "lt q = lt p" and lc_eq: "lc p + lc q = 0"
  shows "lt (p + q) t lt p"
proof (rule ccontr)
  assume "¬ lt (p + q) t lt p"
  hence "lt (p + q) = lt p  lt p t lt (p + q)" by auto
  thus False
  proof
    assume "lt (p + q) = lt p"
    have "lookup (p + q) (lt p) = (lookup p (lt p)) + (lookup q (lt q))" unfolding lt_eq lookup_add ..
    also have "... = lc p + lc q" unfolding lc_def ..
    also have "... = 0" unfolding lc_eq by simp
    finally have "lookup (p + q) (lt p) = 0" .
    hence "lt (p + q)  lt p" using lc_not_0[OF p + q  0] unfolding lc_def by auto
    with ‹lt (p + q) = lt p show False by simp
  next
    assume "lt p t lt (p + q)"
    have "lt p t lt q" by (rule lt_plus_lessE, fact+)
    hence "lt p  lt q" by simp
    with lt_eq show False by simp
  qed
qed

corollary lt_plus_lessI:
  fixes p q :: "'t 0 'b::group_add"
  assumes "p + q  0" and "lt q = lt p" and "lc q = - lc p"
  shows "lt (p + q) t lt p"
  using assms(1, 2)
proof (rule lt_plus_lessI')
  from assms(3) show "lc p + lc q = 0" by simp
qed

lemma lt_plus_distinct_eq_max:
  assumes "lt p  lt q"
  shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
proof (rule ord_term_lin.linorder_cases)
  assume a: "lt p t lt q"
  hence "lt (p + q) = lt q" by (rule lt_plus_eqI)
  also from a have "... = ord_term_lin.max (lt p) (lt q)"
    by (simp add: ord_term_lin.max.absorb2)
  finally show ?thesis .
next
  assume a: "lt q t lt p"
  hence "lt (p + q) = lt p" by (rule lt_plus_eqI_2)
  also from a have "... = ord_term_lin.max (lt p) (lt q)"
    by (simp add: ord_term_lin.max.absorb1)
  finally show ?thesis .
next
  assume "lt p = lt q"
  with assms show ?thesis ..
qed

lemma lt_plus_le_max: "lt (p + q) t ord_term_lin.max (lt p) (lt q)"
proof (cases "lt p = lt q")
  case True
  show ?thesis
  proof (rule lt_le)
    fix u
    assume "ord_term_lin.max (lt p) (lt q) t u"
    hence "lt p t u" and "lt q t u" by simp_all
    hence "lookup p u = 0" and "lookup q u = 0" using lt_max ord_term_lin.leD by blast+
    thus "lookup (p + q) u = 0" by (simp add: lookup_add)
  qed
next
  case False
  hence "lt (p + q) = ord_term_lin.max (lt p) (lt q)" by (rule lt_plus_distinct_eq_max)
  thus ?thesis by simp
qed

lemma lt_minus_eqI: "lt p t lt q  lt (p - q) = lt q" for p q :: "'t 0 'b::ab_group_add"
  by (metis lt_plus_eqI_2 lt_uminus uminus_add_conv_diff)

lemma lt_minus_eqI_2: "lt q t lt p  lt (p - q) = lt p" for p q :: "'t 0 'b::ab_group_add"
  by (metis lt_minus_eqI lt_uminus minus_diff_eq)

lemma lt_minus_eqI_3:
  assumes "lt q = lt p" and "lc q  lc p"
  shows "lt (p - q) = lt (p::'t 0 'b::ab_group_add)"
proof (rule lt_eqI)
  from assms(2) show "lookup (p - q) (lt p)  0" by (simp add: lookup_minus lc_def assms(1))
next
  fix u
  assume "lookup (p - q) u  0"
  hence "lookup p u  lookup q u" by (simp add: lookup_minus)
  hence "lookup p u  0  lookup q u  0" by auto
  thus "u t lt p"
  proof
    assume "lookup p u  0"
    thus ?thesis by (rule lt_max)
  next
    assume "lookup q u  0"
    hence "u t lt q" by (rule lt_max)
    thus ?thesis by (simp only: assms(1))
  qed
qed

lemma lt_minus_distinct_eq_max:
  assumes "lt p  lt (q::'t 0 'b::ab_group_add)"
  shows "lt (p - q) = ord_term_lin.max (lt p) (lt q)"
proof (rule ord_term_lin.linorder_cases)
  assume a: "lt p t lt q"
  hence "lt (p - q) = lt q" by (rule lt_minus_eqI)
  also from a have "... = ord_term_lin.max (lt p) (lt q)"
    by (simp add: ord_term_lin.max.absorb2)
  finally show ?thesis .
next
  assume a: "lt q t lt p"
  hence "lt (p - q) = lt p" by (rule lt_minus_eqI_2)
  also from a have "... = ord_term_lin.max (lt p) (lt q)"
    by (simp add: ord_term_lin.max.absorb1)
  finally show ?thesis .
next
  assume "lt p = lt q"
  with assms show ?thesis ..
qed

lemma lt_minus_lessE: "lt p t lt (p - q)  lt p t lt q" for p q :: "'t 0 'b::ab_group_add"
  using lt_minus_eqI_2 by fastforce

lemma lt_minus_lessE_2: "lt q t lt (p - q)  lt q t lt p" for p q :: "'t 0 'b::ab_group_add"
  using lt_plus_eqI_2 by fastforce

lemma lt_minus_lessI: "p - q  0  lt q = lt p  lc q = lc p  lt (p - q) t lt p"
  for p q :: "'t 0 'b::ab_group_add"
  by (metis (no_types, hide_lams) diff_diff_eq2 diff_self group_eq_aux lc_def lc_not_0 lookup_minus
      lt_minus_eqI ord_term_lin.antisym_conv3)
    
lemma lt_max_keys:
  assumes "v  keys p"
  shows "v t lt p"
proof (rule lt_max)
  from assms show "lookup p v  0" by (simp add: in_keys_iff)
qed

lemma lt_eqI_keys:
  assumes "v  keys p" and a2: "u. u  keys p  u t v"
  shows "lt p = v"
  by (rule lt_eqI, simp_all only: in_keys_iff[symmetric], fact+)
    
lemma lt_gr_keys:
  assumes "u  keys p" and "v t u"
  shows "v t lt p"
proof (rule lt_gr)
  from assms(1) show "lookup p u  0" by (simp add: in_keys_iff)
qed fact

lemma lt_plus_eq_maxI:
  assumes "lt p = lt q  lc p + lc q  0"
  shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
proof (cases "lt p = lt q")
  case True
  show ?thesis
  proof (rule lt_eqI_keys)
    from True have "lc p + lc q  0" by (rule assms)
    thus "ord_term_lin.max (lt p) (lt q)  keys (p + q)"
      by (simp add: in_keys_iff lc_def lookup_add True)
  next
    fix u
    assume "u  keys (p + q)"
    hence "u t lt (p + q)" by (rule lt_max_keys)
    also have "... t ord_term_lin.max (lt p) (lt q)" by (fact lt_plus_le_max)
    finally show "u t ord_term_lin.max (lt p) (lt q)" .
  qed
next
  case False
  thus ?thesis by (rule lt_plus_distinct_eq_max)
qed

lemma lt_monom_mult:
  assumes "c  (0::'b::semiring_no_zero_divisors)" and "p  0"
  shows "lt (monom_mult c t p) = t  lt p"
proof (intro lt_eqI)
  from assms(1) show "lookup (monom_mult c t p) (t  lt p)  0"
  proof (simp add: lookup_monom_mult_plus)
    show "lookup p (lt p)  0"
      using assms(2) lt_in_keys by auto
  qed
next
  fix u::'t
  assume "lookup (monom_mult c t p) u  0"
  hence "u  keys (monom_mult c t p)" by (simp add: in_keys_iff)
  also have "...  (⊕) t ` keys p" by (fact keys_monom_mult_subset)
  finally obtain v where "v  keys p" and "u = t  v" ..
  show "u t t  lt p" unfolding u = t  v
  proof (rule splus_mono)
    from v  keys p show "v t lt p" by (rule lt_max_keys)
  qed
qed

lemma lt_monom_mult_zero:
  assumes "c  (0::'b::semiring_no_zero_divisors)"
  shows "lt (monom_mult c 0 p) = lt p"
proof (cases "p = 0")
  case True
  show ?thesis by (simp add: True)
next
  case False
  with assms show ?thesis by (simp add: lt_monom_mult term_simps)
qed

corollary lt_map_scale: "c  (0::'b::semiring_no_zero_divisors)  lt (c  p) = lt p"
  by (simp add: map_scale_eq_monom_mult lt_monom_mult_zero)

lemma lc_monom_mult [simp]: "lc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * lc p"
proof (cases "c = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (cases "p = 0")
    case True
    thus ?thesis by simp
  next
    case False
    with c  0 show ?thesis by (simp add: lc_def lt_monom_mult lookup_monom_mult_plus)
  qed
qed

corollary lc_map_scale [simp]: "lc (c  p) = (c::'b::semiring_no_zero_divisors) * lc p"
  by (simp add: map_scale_eq_monom_mult)

lemma (in ordered_term) lt_mult_scalar_monomial_right:
  assumes "c  (0::'b::semiring_no_zero_divisors)" and "p  0"
  shows "lt (p  monomial c v) = punit.lt p  v"
proof (intro lt_eqI)
  from assms(1) show "lookup (p  monomial c v) (punit.lt p  v)  0"
  proof (simp add: lookup_mult_scalar_monomial_right_plus)
    from assms(2) show "lookup p (punit.lt p)  0"
      using in_keys_iff punit.lt_in_keys by fastforce
  qed
next
  fix u::'t
  assume "lookup (p  monomial c v) u  0"
  hence "u  keys (p  monomial c v)" by (simp add: in_keys_iff)
  also have "...  (λt. t  v) ` keys p" by (fact keys_mult_scalar_monomial_right_subset)
  finally obtain t where "t  keys p" and "u = t  v" ..
  show "u t punit.lt p  v" unfolding u = t  v
  proof (rule splus_mono_left)
    from t  keys p show "t  punit.lt p" by (rule punit.lt_max_keys)
  qed
qed

lemma lc_mult_scalar_monomial_right:
  "lc (p  monomial c v) = punit.lc p * (c::'b::semiring_no_zero_divisors)"
proof (cases "c = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (cases "p = 0")
    case True
    thus ?thesis by simp
  next
    case False
    with c  0 show ?thesis
      by (simp add: punit.lc_def lc_def lt_mult_scalar_monomial_right lookup_mult_scalar_monomial_right_plus)
  qed
qed

lemma lookup_monom_mult_eq_zero:
  assumes "s  lt p t v"
  shows "lookup (monom_mult (c::'b::semiring_no_zero_divisors) s p) v = 0"
  by (metis assms aux lt_gr lt_monom_mult monom_mult_zero_left monom_mult_zero_right
      ord_term_lin.order.strict_implies_not_eq)

lemma in_keys_monom_mult_le:
  assumes "v  keys (monom_mult c t p)"
  shows "v t t  lt p"
proof -
  from keys_monom_mult_subset assms have "v  (⊕) t ` (keys p)" ..
  then obtain u where "u  keys p" and "v = t  u" ..
  from u  keys p have "u t lt p" by (rule lt_max_keys)
  thus "v t t  lt p" unfolding v = t  u by (rule splus_mono)
qed

lemma lt_monom_mult_le: "lt (monom_mult c t p) t t  lt p"
  by (metis aux in_keys_monom_mult_le lt_in_keys lt_le_iff)

lemma monom_mult_inj_2:
  assumes "monom_mult c t1 p = monom_mult c t2 p"
    and "c  0" and "(p::'t 0 'b::semiring_no_zero_divisors)  0"
  shows "t1 = t2"
proof -
  from assms(1) have "lt (monom_mult c t1 p) = lt (monom_mult c t2 p)" by simp
  with c  0 p  0 have "t1  lt p = t2  lt p" by (simp add: lt_monom_mult)
  thus ?thesis by (simp add: term_simps)
qed

subsection ‹Trailing Term and Trailing Coefficient: @{const tt} and @{const tc}

lemma tt_zero [simp]: "tt 0 = min_term"
  by (simp add: tt_def)

lemma tc_zero [simp]: "tc 0 = 0"
  by (simp add: tc_def)

lemma tt_alt:
  assumes "p  0"
  shows "tt p = ord_term_lin.Min (keys p)"
  using assms unfolding tt_def by simp

lemma tt_min_keys:
  assumes "v  keys p"
  shows "tt p t v"
proof -
  from assms have "keys p  {}" by auto
  hence "p  0" by simp
  from tt_alt[OF this] ord_term_lin.Min_le[OF finite_keys assms] show ?thesis by simp
qed

lemma tt_min:
  assumes "lookup p v  0"
  shows "tt p t v"
proof -
  from assms have "v  keys p" unfolding keys_def by simp
  thus ?thesis by (rule tt_min_keys)
qed
  
lemma tt_in_keys:
  assumes "p  0"
  shows "tt p  keys p"
  unfolding tt_alt[OF assms]
  by (rule ord_term_lin.Min_in, fact finite_keys, simp add: assms)

lemma tt_eqI:
  assumes "v  keys p" and "u. u  keys p  v t u"
  shows "tt p = v"
proof -
  from assms(1) have "keys p  {}" by auto
  hence "p  0" by simp
  from assms(1) have "tt p t v" by (rule tt_min_keys)
  moreover have "v t tt p" by (rule assms(2), rule tt_in_keys, fact p  0)
  ultimately show ?thesis by simp
qed

lemma tt_gr:
  assumes "u. u  keys p  v t u" and "p  0"
  shows "v t tt p"
proof -
  from p  0 have "keys p  {}" by simp
  show ?thesis by (rule assms(1), rule tt_in_keys, fact p  0)
qed

lemma tt_less:
  assumes "u  keys p" and "u t v"
  shows "tt p t v"
proof -
  from u  keys p have "tt p t u" by (rule tt_min_keys)
  also have "... t v" by fact
  finally show "tt p t v" .
qed

lemma tt_ge:
  assumes "u. u t v  lookup p u = 0" and "p  0"
  shows "v t tt p"
proof -
  from p  0 have "keys p  {}" by simp
  have "ukeys p. v t u"
  proof
    fix u::'t
    assume "u  keys p"
    hence "lookup p u  0" unfolding keys_def by simp
    hence "¬ u t v" using assms(1)[of u] by auto
    thus "v t u" by simp
  qed
  with tt_alt[OF p  0] ord_term_lin.Min_ge_iff[OF finite_keys[of p] ‹keys p  {}]
    show ?thesis by simp
qed
  
lemma tt_ge_keys:
  assumes "u. u  keys p  v t u" and "p  0"
  shows "v t tt p"
  by (rule assms(1), rule tt_in_keys, fact)

lemma tt_ge_iff: "v t tt p  ((p  0  v = min_term)  (u. u t v  lookup p u = 0))"
  (is "?L  (?A  ?B)")
proof
  assume ?L
  show "?A  ?B"
  proof (intro conjI allI impI)
    show "p  0  v = min_term"
    proof (cases "p = 0")
      case True
      show ?thesis
      proof (rule disjI2)
        from ?L True have "v t min_term" by (simp add: tt_def)
        with min_term_min[of v] show "v = min_term" by simp
      qed
    next
      case False
      thus ?thesis ..
    qed
  next
    fix u
    assume "u t v"
    also note v t tt p
    finally have "u t tt p" .
    hence "¬ tt p t u" by simp
    with tt_min[of p u] show "lookup p u = 0" by blast
  qed
next
  assume "?A  ?B"
  hence ?A and ?B by simp_all
  show ?L
  proof (cases "p = 0")
    case True
    with ?A have "v = min_term" by simp
    with True show ?thesis by (simp add: tt_def)
  next
    case False
    from ?B show ?thesis using tt_ge[OF _ False] by auto
  qed
qed

lemma tc_not_0:
  assumes "p  0"
  shows "tc p  0"
  unfolding tc_def in_keys_iff[symmetric] using assms by (rule tt_in_keys)

lemma tt_monomial:
  assumes "c  0"
  shows "tt (monomial c v) = v"
proof (rule tt_eqI)
  from keys_of_monomial[OF assms, of v] show "v  keys (monomial c v)" by simp
next
  fix u
  assume "u  keys (monomial c v)"
  with keys_of_monomial[OF assms, of v] have "u = v" by simp
  thus "v t u" by simp
qed

lemma tc_monomial [simp]: "tc (monomial c t) = c"
proof (cases "c = 0")
  case True
  thus ?thesis by simp
next
  case False
  thus ?thesis by (simp add: tc_def tt_monomial)
qed
  
lemma tt_plus_eqI:
  assumes "p  0" and "tt p t tt q"
  shows "tt (p + q) = tt p"
proof (intro tt_eqI)
  from tt_less[of "tt p" q "tt q"] ‹tt p t tt q have "tt p  keys q" by blast
  with lookup_add[of p q "tt p"] tc_not_0[OF p  0] show "tt p  keys (p + q)"
    unfolding in_keys_iff tc_def by simp
next
  fix u
  assume "u  keys (p + q)"
  show "tt p t u"
  proof (rule ccontr)
    assume "¬ tt p t u"
    hence sp: "u t tt p" by simp
    hence "u t tt q" using ‹tt p t tt q by simp
    with tt_less[of u q "tt q"] have "u  keys q" by blast
    moreover from sp tt_less[of u p "tt p"] have "u  keys p" by blast
    ultimately show False using u  keys (p + q) Poly_Mapping.keys_add[of p q] by auto
  qed
qed
    
lemma tt_plus_lessE:
  fixes p q
  assumes "p + q  0" and tt: "tt (p + q) t tt p"
  shows "tt q t tt p"
proof (cases "p = 0")
  case True
  with tt show ?thesis by simp
next
  case False
  show ?thesis
  proof (rule ccontr)
    assume "¬ tt q t tt p"
    hence "tt p = tt q  tt p t tt q" by auto
    thus False
    proof
      assume tt_eq: "tt p = tt q"
      have "tt p t tt (p + q)"
      proof (rule tt_ge_keys)
        fix u
        assume "u  keys (p + q)"
        hence "u  keys p  keys q"
        proof
          show "keys (p + q)  keys p  keys q" by (fact Poly_Mapping.keys_add)
        qed
        thus "tt p t u"
        proof
          assume "u  keys p"
          thus ?thesis by (rule tt_min_keys)
        next
          assume "u  keys q"
          thus ?thesis unfolding tt_eq by (rule tt_min_keys)
        qed
      qed (fact p + q  0)
      with tt show False by simp
    next
      assume "tt p t tt q"
      from tt_plus_eqI[OF False this] tt show False by (simp add: ac_simps)
    qed
  qed
qed
  
lemma tt_plus_lessI:
  fixes p q :: "_ 0 'b::ring"
  assumes "p + q  0" and tt_eq: "tt q = tt p" and tc_eq: "tc q = - tc p"
  shows "tt p t tt (p + q)"
proof (rule ccontr)
  assume "¬ tt p t tt (p + q)"
  hence "tt p = tt (p + q)  tt (p + q) t tt p" by auto
  thus False
  proof
    assume "tt p = tt (p + q)"
    have "lookup (p + q) (tt p) = (lookup p (tt p)) + (lookup q (tt q))" unfolding tt_eq lookup_add ..
    also have "... = tc p + tc q" unfolding tc_def ..
    also have "... = 0" unfolding tc_eq by simp
    finally have "lookup (p + q) (tt p) = 0" .
    hence "tt (p + q)  tt p" using tc_not_0[OF p + q  0] unfolding tc_def by auto
    with ‹tt p = tt (p + q) show False by simp
  next
    assume "tt (p + q) t tt p"
    have "tt q t tt p" by (rule tt_plus_lessE, fact+)
    hence "tt q  tt p" by simp
    with tt_eq show False by simp
  qed
qed

lemma tt_uminus [simp]: "tt (- p) = tt p"
  by (simp add: tt_def keys_uminus)

lemma tc_uminus [simp]: "tc (- p) = - tc p"
  by (simp add: tc_def)

lemma tt_monom_mult:
  assumes "c  (0::'b::semiring_no_zero_divisors)" and "p  0"
  shows "tt (monom_mult c t p) = t  tt p"
proof (intro tt_eqI, rule keys_monom_multI, rule tt_in_keys, fact, fact)
  fix u
  assume "u  keys (monom_mult c t p)"
  then obtain v where "v  keys p" and u: "u = t  v" by (rule keys_monom_multE)
  show "t  tt p t u" unfolding u add.commute[of t] by (rule splus_mono, rule tt_min_keys, fact)
qed

lemma tt_map_scale: "c  (0::'b::semiring_no_zero_divisors)  tt (c  p) = tt p"
  by (cases "p = 0") (simp_all add: map_scale_eq_monom_mult tt_monom_mult term_simps)

lemma tc_monom_mult [simp]: "tc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * tc p"
proof (cases "c = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (cases "p = 0")
    case True
    thus ?thesis by simp
  next
    case False
    with c  0 show ?thesis by (simp add: tc_def tt_monom_mult lookup_monom_mult_plus)
  qed
qed

corollary tc_map_scale [simp]: "tc (c  p) = (c::'b::semiring_no_zero_divisors) * tc p"
  by (simp add: map_scale_eq_monom_mult)

lemma in_keys_monom_mult_ge:
  assumes "v  keys (monom_mult c t p)"
  shows "t  tt p t v"
proof -
  from keys_monom_mult_subset assms have "v  (⊕) t ` (keys p)" ..
  then obtain u where "u  keys p" and "v = t  u" ..
  from u  keys p have "tt p t u" by (rule tt_min_keys)
  thus "t  tt p t v" unfolding v = t  u by (rule splus_mono)
qed

lemma lt_ge_tt: "tt p t lt p"
proof (cases "p = 0")
  case True
  show ?thesis unfolding True lt_def tt_def by simp
next
  case False
  show ?thesis by (rule lt_max_keys, rule tt_in_keys, fact False)
qed

lemma lt_eq_tt_monomial:
  assumes "is_monomial p"
  shows "lt p = tt p"
proof -
  from assms obtain c v where "c  0" and p: "p = monomial c v" by (rule is_monomial_monomial)
  from c  0 have "lt p = v" and "tt p = v" unfolding p by (rule lt_monomial, rule tt_monomial)
  thus ?thesis by simp
qed

subsection @{const higher} and @{const lower}

lemma lookup_higher: "lookup (higher p u) v = (if u t v then lookup p v else 0)"
  by (auto simp add: higher_def lookup_except)

lemma lookup_higher_when: "lookup (higher p u) v = (lookup p v when u t v)"
  by (auto simp add: lookup_higher when_def)

lemma higher_plus: "higher (p + q) v = higher p v + higher q v"
  by (rule poly_mapping_eqI, simp add: lookup_add lookup_higher)

lemma higher_uminus [simp]: "higher (- p) v = -(higher p v)"
  by (rule poly_mapping_eqI, simp add: lookup_higher)

lemma higher_minus: "higher (p - q) v = higher p v - higher q v"
  by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_higher)

lemma higher_zero [simp]: "higher 0 t = 0"
  by (rule poly_mapping_eqI, simp add: lookup_higher)

lemma higher_eq_iff: "higher p v = higher q v  (u. v t u  lookup p u = lookup q u)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (intro allI impI)
    fix u
    assume "v t u"
    moreover from ?L have "lookup (higher p v) u = lookup (higher q v) u" by simp
    ultimately show "lookup p u = lookup q u" by (simp add: lookup_higher)
  qed
next
  assume ?R
  show ?L
  proof (rule poly_mapping_eqI, simp add: lookup_higher, rule)
    fix u
    assume "v t u"
    with ?R show "lookup p u = lookup q u" by simp
  qed
qed

lemma higher_eq_zero_iff: "higher p v = 0  (u. v t u  lookup p u = 0)"
proof -
  have "higher p v = higher 0 v  (u. v t u  lookup p u = lookup 0 u)" by (rule higher_eq_iff)
  thus ?thesis by simp
qed

lemma keys_higher: "keys (higher p v) = {ukeys p. v t u}"
  by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_higher)

lemma higher_higher: "higher (higher p u) v = higher p (ord_term_lin.max u v)"
  by (rule poly_mapping_eqI, simp add: lookup_higher)

lemma lookup_lower: "lookup (lower p u) v = (if v t u then lookup p v else 0)"
  by (auto simp add: lower_def lookup_except)

lemma lookup_lower_when: "lookup (lower p u) v = (lookup p v when v t u)"
  by (auto simp add: lookup_lower when_def)

lemma lower_plus: "lower (p + q) v = lower p v + lower q v"
  by (rule poly_mapping_eqI, simp add: lookup_add lookup_lower)

lemma lower_uminus [simp]: "lower (- p) v = - lower p v"
  by (rule poly_mapping_eqI, simp add: lookup_lower)

lemma lower_minus:  "lower (p - (q::_ 0 'b::ab_group_add)) v = lower p v - lower q v"
   by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_lower)

lemma lower_zero [simp]: "lower 0 v = 0"
  by (rule poly_mapping_eqI, simp add: lookup_lower)

lemma lower_eq_iff: "lower p v = lower q v  (u. u t v  lookup p u = lookup q u)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (intro allI impI)
    fix u
    assume "u t v"
    moreover from ?L have "lookup (lower p v) u = lookup (lower q v) u" by simp
    ultimately show "lookup p u = lookup q u" by (simp add: lookup_lower)
  qed
next
  assume ?R
  show ?L
  proof (rule poly_mapping_eqI, simp add: lookup_lower, rule)
    fix u
    assume "u t v"
    with ?R show "lookup p u = lookup q u" by simp
  qed
qed

lemma lower_eq_zero_iff: "lower p v = 0  (u. u t v  lookup p u = 0)"
proof -
  have "lower p v = lower 0 v  (u. u t v  lookup p u = lookup 0 u)" by (rule lower_eq_iff)
  thus ?thesis by simp
qed

lemma keys_lower: "keys (lower p v) = {ukeys p. u t v}"
  by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_lower)

lemma lower_lower: "lower (lower p u) v = lower p (ord_term_lin.min u v)"
  by (rule poly_mapping_eqI, simp add: lookup_lower)

lemma lt_higher:
  assumes "v t lt p"
  shows "lt (higher p v) = lt p"
proof (rule lt_eqI_keys, simp_all add: keys_higher, rule conjI, rule lt_in_keys, rule)
  assume "p = 0"
  hence "lt p = min_term" by (simp add: lt_def)
  with min_term_min[of v] assms show False by simp
next
  fix u
  assume "u  keys p  v t u"
  hence "u  keys p" ..
  thus "u t lt p" by (rule lt_max_keys)
qed fact

lemma lc_higher:
  assumes "v t lt p"
  shows "lc (higher p v) = lc p"
  by (simp add: lc_def lt_higher assms lookup_higher)

lemma higher_eq_zero_iff': "higher p v = 0  lt p t v"
  by (simp add: higher_eq_zero_iff lt_le_iff)

lemma higher_id_iff: "higher p v = p  (p = 0  v t tt p)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (cases "p = 0")
    case True
    thus ?thesis ..
  next
    case False
    show ?thesis
    proof (rule disjI2, rule tt_gr)
      fix u
      assume "u  keys p"
      hence "lookup p u  0" by (simp add: in_keys_iff)
      from ?L have "lookup (higher p v) u = lookup p u" by simp
      hence "lookup p u = (if v t u then lookup p u else 0)" by (simp only: lookup_higher)
      hence "¬ v t u  lookup p u = 0" by simp
      with ‹lookup p u  0 show "v t u" by auto
    qed fact
  qed
next
  assume ?R
  show ?L
  proof (cases "p = 0")
    case True
    thus ?thesis by simp
  next
    case False
    with ?R have "v t tt p" by simp
    show ?thesis
    proof (rule poly_mapping_eqI, simp add: lookup_higher, intro impI)
      fix u
      assume "¬ v t u"
      hence "u t v" by simp
      from this v t tt p have "u t tt p" by simp
      hence "¬ tt p t u" by simp
      with tt_min[of p u] show "lookup p u = 0" by blast
    qed
  qed
qed

lemma tt_lower:
  assumes "tt p t v"
  shows "tt (lower p v) = tt p"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (rule tt_eqI, simp_all add: keys_lower, rule, rule tt_in_keys)
    fix u
    assume "u  keys p  u t v"
    hence "u  keys p" ..
    thus "tt p t u" by (rule tt_min_keys)
  qed fact+
qed

lemma tc_lower:
  assumes "tt p t v"
  shows "tc (lower p v) = tc p"
  by (simp add: tc_def tt_lower assms lookup_lower)

lemma lt_lower: "lt (lower p v) t lt p"
proof (cases "lower p v = 0")
  case True
  thus ?thesis by (simp add: lt_def min_term_min)
next
  case False
  show ?thesis
  proof (rule lt_le, simp add: lookup_lower, rule impI, rule ccontr)
    fix u
    assume "lookup p u  0"
    hence "u t lt p" by (rule lt_max)
    moreover assume "lt p t u"
    ultimately show False by simp
  qed
qed

lemma lt_lower_less:
  assumes "lower p v  0"
  shows "lt (lower p v) t v"
  using assms
proof (rule lt_less)
  fix u
  assume "v t u"
  thus "lookup (lower p v) u = 0" by (simp add: lookup_lower_when)
qed

lemma lt_lower_eq_iff: "lt (lower p v) = lt p  (lt p = min_term  lt p t v)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (rule ccontr, simp, elim conjE)
    assume "lt p  min_term"
    hence "min_term t lt p" using min_term_min ord_term_lin.dual_order.not_eq_order_implies_strict
      by blast
    assume "¬ lt p t v"
    hence "v t lt p" by simp
    have "lt (lower p v) t lt p"
    proof (cases "lower p v = 0")
      case True
      thus ?thesis using ‹min_term t lt p by (simp add: lt_def)
    next
      case False
      show ?thesis
      proof (rule lt_less)
        fix u
        assume "lt p t u"
        with v t lt p have "¬ u t v" by simp
        thus "lookup (lower p v) u = 0" by (simp add: lookup_lower)
      qed fact
    qed
    with ?L show False by simp
  qed
next
  assume ?R
  show ?L
  proof (cases "lt p = min_term")
    case True
    hence "lt p t lt (lower p v)" by (simp add: min_term_min)
    with lt_lower[of p v] show ?thesis by simp
  next
    case False
    with ?R have "lt p t v" by simp
    show ?thesis
    proof (rule lt_eqI_keys, simp_all add: keys_lower, rule conjI, rule lt_in_keys, rule)
      assume "p = 0"
      hence "lt p = min_term" by (simp add: lt_def)
      with False show False ..
    next
      fix u
      assume "u  keys p  u t v"
      hence "u  keys p" ..
      thus "u t lt p" by (rule lt_max_keys)
    qed fact
  qed
qed

lemma tt_higher:
  assumes "v t lt p"
  shows "tt p t tt (higher p v)"
proof (rule tt_ge_keys, simp add: keys_higher)
  fix u
  assume "u  keys p  v t u"
  hence "u  keys p" ..
  thus "tt p t u" by (rule tt_min_keys)
next
  show "higher p v  0"
  proof (simp add: higher_eq_zero_iff, intro exI conjI)
    have "p  0"
    proof
      assume "p = 0"
      hence "lt p t v" by (simp add: lt_def min_term_min)
      with assms show False by simp
    qed
    thus "lookup p (lt p)  0"
      using lt_in_keys by auto 
  qed fact
qed

lemma tt_higher_eq_iff:
  "tt (higher p v) = tt p  ((lt p t v  tt p = min_term)  v t tt p)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (rule ccontr, simp, elim conjE)
    assume a: "lt p t v  tt p  min_term"
    assume "¬ v t tt p"
    hence "tt p t v" by simp
    have "tt p t tt (higher p v)"
    proof (cases "higher p v = 0")
      case True
      with ?L have "tt p = min_term" by (simp add: tt_def)
      with a have "v t lt p" by auto
      have "lt p  min_term"
      proof
        assume "lt p = min_term"
        with v t lt p show False using min_term_min[of v] by auto
      qed
      hence "p  0" by (auto simp add: lt_def)
      from v t lt p have "higher p v  0" by (simp add: higher_eq_zero_iff')
      from this True show ?thesis ..
    next
      case False
      show ?thesis
      proof (rule tt_gr)
        fix u
        assume "u  keys (higher p v)"
        hence "v t u" by (simp add: keys_higher)
        with ‹tt p t v show "tt p t u" by simp
      qed fact
    qed
    with ?L show False by simp
  qed
next
  assume ?R
  show ?L
  proof (cases "lt p t v  tt p = min_term")
    case True
    hence "lt p t v" and "tt p = min_term" by simp_all
    from ‹lt p t v have "higher p v = 0" by (simp add: higher_eq_zero_iff')
    with ‹tt p = min_term› show ?thesis by (simp add: tt_def)
  next
    case False
    with ?R have "v t tt p" by simp
    show ?thesis
    proof (rule tt_eqI, simp_all add: keys_higher, rule conjI, rule tt_in_keys, rule)
      assume "p = 0"
      hence "tt p = min_term" by (simp add: tt_def)
      with v t tt p min_term_min[of v] show False by simp
    next
      fix u
      assume "u  keys p  v t u"
      hence "u  keys p" ..
      thus "tt p t u" by (rule tt_min_keys)
    qed fact
  qed
qed

lemma lower_eq_zero_iff': "lower p v = 0  (p = 0  v t tt p)"
  by (auto simp add: lower_eq_zero_iff tt_ge_iff)

lemma lower_id_iff: "lower p v = p  (p = 0  lt p t v)" (is "?L  ?R")
proof
  assume ?L
  show ?R
  proof (cases "p = 0")
    case True
    thus ?thesis ..
  next
    case False
    show ?thesis
    proof (rule disjI2, rule lt_less)
      fix u
      assume "v t u"
      from ?L have "lookup (lower p v) u = lookup p u" by simp
      hence "lookup p u = (if u t v then lookup p u else 0)" by (simp only: lookup_lower)
      hence "v t u  lookup p u = 0" by (meson ord_term_lin.leD)
      with v t u show "lookup p u = 0" by simp
    qed fact
  qed
next
  assume ?R
  show ?L
  proof (cases "p = 0", simp)
    case False
    with ?R have "lt p t v" by simp
    show ?thesis
    proof (rule poly_mapping_eqI, simp add: lookup_lower, intro impI)
      fix u
      assume "¬ u t v"
      hence "v t u" by simp
      with ‹lt p t v have "lt p t u" by simp
      hence "¬ u t lt p" by simp
      with lt_max[of p u] show "lookup p u = 0" by blast
    qed
  qed
qed
    
lemma lower_higher_commute: "higher (lower p s) t = lower (higher p t) s"
  by (rule poly_mapping_eqI, simp add: lookup_higher lookup_lower)

lemma lt_lower_higher:
  assumes "v t lt (lower p u)"
  shows "lt (lower (higher p v) u) = lt (lower p u)"
  by (simp add: lower_higher_commute[symmetric] lt_higher[OF assms])

lemma lc_lower_higher:
  assumes "v t lt (lower p u)"
  shows "lc (lower (higher p v) u) = lc (lower p u)"
  using assms by (simp add: lc_def lt_lower_higher lookup_lower lookup_higher)

lemma trailing_monomial_higher:
  assumes "p  0"
  shows "p = (higher p (tt p)) + monomial (tc p) (tt p)"
proof (rule poly_mapping_eqI, simp only: lookup_add)
  fix v
  show "lookup p v = lookup (higher p (tt p)) v + lookup (monomial (tc p) (tt p)) v"
  proof (cases "tt p t v")
    case True
    show ?thesis
    proof (cases "v = tt p")
      assume "v = tt p"
      hence "¬ tt p t v" by simp
      hence "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
      moreover from v = tt p have "lookup (monomial (tc p) (tt p)) v = tc p" by (simp add: lookup_single)
      moreover from v = tt p have "lookup p v = tc p" by (simp add: tc_def)
      ultimately show ?thesis by simp
    next
      assume "v  tt p"
      from this True have "tt p t v" by simp
      hence "lookup (higher p (tt p)) v = lookup p v" by (simp add: lookup_higher)
      moreover from v  tt p have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
      ultimately show ?thesis by simp
    qed
  next
    case False
    hence "v t tt p" by simp
    hence "tt p  v" by simp
    from False have "¬ tt p t v" by simp
    have "lookup p v = 0"
    proof (rule ccontr)
      assume "lookup p v  0"
      from tt_min[OF this] False show False by simp
    qed
    moreover from ‹tt p  v have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
    moreover from ¬ tt p t v have "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
    ultimately show ?thesis by simp
  qed
qed

lemma higher_lower_decomp: "higher p v + monomial (lookup p v) v + lower p v = p"
proof (rule poly_mapping_eqI)
  fix u
  show "lookup (higher p v + monomial (lookup p v) v + lower p v) u = lookup p u"
  proof (rule ord_term_lin.linorder_cases)
    assume "u t v"
    thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
  next
    assume "u = v"
    thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
  next
    assume "v t u"
    thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
  qed
qed

subsection @{const tail}

lemma lookup_tail: "lookup (tail p) v = (if v t lt p then lookup p v else 0)"
  by (simp add: lookup_lower tail_def)

lemma lookup_tail_when: "lookup (tail p) v = (lookup p v when v t lt p)"
  by (simp add: lookup_lower_when tail_def)

lemma lookup_tail_2: "lookup (tail p) v = (if v = lt p then 0 else lookup p v)"
proof (rule ord_term_lin.linorder_cases[of v "lt p"])
  assume "v t lt p"
  hence "v  lt p" by simp
  from this v t lt p lookup_tail[of p v] show ?thesis by simp
next
  assume "v = lt p"
  hence "¬ v t lt p" by simp
  from v = lt p this lookup_tail[of p v] show ?thesis by simp
next
  assume "lt p t v"
  hence "¬ v t lt p" by simp
  hence cp: "lookup p v = 0"
    using lt_max by blast
  from ¬ v t lt p have "¬ v = lt p" and "¬ v t lt p" by simp_all
  thus ?thesis using cp lookup_tail[of p v] by simp
qed

lemma leading_monomial_tail: "p = monomial (lc p) (lt p) + tail p" for p::"_ 0 'b::comm_monoid_add"
proof (rule poly_mapping_eqI)
  fix v
  have "lookup p v = lookup (monomial (lc p) (lt p)) v + lookup (tail p) v"
  proof (cases "v t lt p")
    case True
    show ?thesis
    proof (cases "v = lt p")
      assume "v = lt p"
      hence "¬ v t lt p" by simp
      hence c3: "lookup (tail p) v = 0" unfolding lookup_tail[of p v] by simp
      from v = lt p have c2: "lookup (monomial (lc p) (lt p)) v = lc p" by simp
      from v = lt p have c1: "lookup p v = lc p" by (simp add: lc_def)
      from c1 c2 c3 show ?thesis by simp
    next
      assume "v  lt p"
      from this True have "v t lt p" by simp
      hence c2: "lookup (tail p) v = lookup p v" unfolding lookup_tail[of p v] by simp
      from v  lt p have c1: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
      from c1 c2 show ?thesis by simp
    qed
  next
    case False
    hence "lt p t v" by simp
    hence "lt p  v" by simp
    from False have "¬ v t lt p" by simp
    have c1: "lookup p v = 0"
    proof (rule ccontr)
      assume "lookup p v  0"
      from lt_max[OF this] False show False by simp
    qed
    from ‹lt p  v have c2: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
    from ¬ v t lt p lookup_tail[of p v] have c3: "lookup (tail p) v = 0" by simp
    from c1 c2 c3 show ?thesis by simp
  qed
  thus "lookup p v = lookup (monomial (lc p) (lt p) + tail p) v" by (simp add: lookup_add)
qed

lemma tail_alt: "tail p = except p {lt p}"
  by (rule poly_mapping_eqI, simp add: lookup_tail_2 lookup_except)

corollary tail_alt_2: "tail p = p - monomial (lc p) (lt p)"
proof -
  have "p = monomial (lc p) (lt p) + tail p" by (fact leading_monomial_tail)
  also have "... = tail p + monomial (lc p) (lt p)" by (simp only: add.commute)
  finally have "p - monomial (lc p) (lt p) = (tail p + monomial (lc p) (lt p)) - monomial (lc p) (lt p)" by simp
  thus ?thesis by simp
qed

lemma tail_zero [simp]: "tail 0 = 0"
  by (simp only: tail_alt except_zero)

lemma lt_tail:
  assumes "tail p  0"
  shows "lt (tail p) t lt p"
proof (intro lt_less)
  fix u
  assume "lt p t u"
  hence "¬ u t lt p" by simp
  thus "lookup (tail p) u = 0" unfolding lookup_tail[of p u] by simp
qed fact

lemma keys_tail: "keys (tail p) = keys p - {lt p}"
  by (simp add: tail_alt keys_except)

lemma tail_monomial: "tail (monomial c v) = 0"
  by (metis (no_types, lifting) lookup_tail_2 lookup_single_not_eq lt_less lt_monomial
      ord_term_lin.dual_order.strict_implies_not_eq single_zero tail_zero)

lemma (in ordered_term) mult_scalar_tail_rec_left:
  "p  q = monom_mult (punit.lc p) (punit.lt p) q + (punit.tail p)  q"
  unfolding punit.lc_def punit.tail_alt by (fact mult_scalar_rec_left)

lemma mult_scalar_tail_rec_right: "p  q = p  monomial (lc q) (lt q) + p  tail q"
  unfolding tail_alt lc_def by (rule mult_scalar_rec_right)

lemma lt_tail_max:
  assumes "tail p  0" and "v  keys p" and "v t lt p"
  shows "v t lt (tail p)"
proof (rule lt_max_keys, simp add: keys_tail assms(2))
  from assms(3) show "v  lt p" by auto
qed

lemma keys_tail_less_lt:
  assumes "v  keys (tail p)"
  shows "v t lt p"
  using assms by (meson in_keys_iff lookup_tail)

lemma tt_tail:
  assumes "tail p  0"
  shows "tt (tail p) = tt p"
proof (rule tt_eqI, simp_all add: keys_tail)
  from assms have "p  0" using tail_zero by auto
  show "tt p  keys p  tt p  lt p"
  proof (rule conjI, rule tt_in_keys, fact)
    have "tt p t lt p"
      by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
    thus "tt p  lt p" by simp
  qed
next
  fix u
  assume "u  keys p  u  lt p"
  hence "u  keys p" ..
  thus "tt p t u" by (rule tt_min_keys)
qed

lemma tc_tail:
  assumes "tail p  0"
  shows "tc (tail p) = tc p"
proof (simp add: tc_def tt_tail[OF assms] lookup_tail_2, rule)
  assume "tt p = lt p"
  moreover have "tt p t lt p"
    by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
  ultimately show "lookup p (lt p) = 0" by simp
qed

lemma tt_tail_min:
  assumes "s  keys p"
  shows "tt (tail p) t s"
proof (cases "tail p = 0")
  case True
  hence "tt (tail p) = min_term" by (simp add: tt_def)
  thus ?thesis by (simp add: min_term_min)
next
  case False
  from assms show ?thesis by (simp add: tt_tail[OF False], rule tt_min_keys)
qed

lemma tail_monom_mult:
  "tail (monom_mult c t p) = monom_mult (c::'b::semiring_no_zero_divisors) t (tail p)"
proof (cases "p = 0")
  case True
  hence "tail p = 0" and "monom_mult c t p = 0" by simp_all
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (cases "c = 0")
    case True
    hence "monom_mult c t p = 0" and "monom_mult c t (tail p) = 0" by simp_all
    thus ?thesis by simp
  next
    case False
    let ?a = "monom_mult c t p"
    let ?b = "monom_mult c t (tail p)"
    from p  0 False have "?a  0" by (simp add: monom_mult_eq_zero_iff)
    from False p  0 have lt_a: "lt ?a = t  lt p" by (rule lt_monom_mult)
    show ?thesis
    proof (rule poly_mapping_eqI, simp add: lookup_tail lt_a, intro conjI impI)
      fix u
      assume "u t t  lt p"
      show "lookup (monom_mult c t p) u = lookup (monom_mult c t (tail p)) u"
      proof (cases "t addsp u")
        case True
        then obtain v where "u = t  v" by (rule adds_ppE)
        from u t t  lt p have "v t lt p" unfolding u = t  v by (rule ord_term_strict_canc) 
        hence "lookup p v = lookup (tail p) v" by (simp add: lookup_tail)
        thus ?thesis by (simp add: u = t  v lookup_monom_mult_plus)
      next
        case False
        hence "lookup ?a u = 0" by (simp add: lookup_monom_mult)
        moreover have "lookup ?b u = 0"
          proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF c  0])
          assume "u  (⊕) t ` keys (tail p)"
          then obtain v where "u = t  v" by auto
          hence "t addsp u" by (simp add: term_simps)
          with False show False ..
        qed
        ultimately show ?thesis by simp
      qed
    next
      fix u
      assume "¬ u t t  lt p"
      hence "t  lt p t u" by simp
      show "lookup (monom_mult c t (tail p)) u = 0"
      proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF False])
        assume "u  (⊕) t ` keys (tail p)"
        then obtain v where "v  keys (tail p)" and "u = t  v" by auto
        from t  lt p t u have "lt p t v" unfolding u = t  v by (rule ord_term_canc)
        from v  keys (tail p) have "v  keys p" and "v  lt p" by (simp_all add: keys_tail)
        from v  keys p have "v t lt p" by (rule lt_max_keys)
        with ‹lt p t v have "v = lt p " by simp
        with v  lt p show False ..
      qed
    qed
  qed
qed

lemma keys_plus_eq_lt_tt_D:
  assumes "keys (p + q) = {lt p, tt q}" and "lt q t lt p" and "tt q t tt (p::_ 0 'b::comm_monoid_add)"
  shows "tail p + higher q (tt q) = 0"
proof -
  note assms(3)
  also have "... t lt p" by (rule lt_ge_tt)
  finally have "tt q t lt p" .
  hence "lt p  tt q" by simp
  have "q  0"
  proof
    assume "q = 0"
    hence "tt q = min_term" by (simp add: tt_def)
    with q = 0 assms(1) have "keys p = {lt p, min_term}" by simp
    hence "min_term  keys p" by simp
    hence "tt p t tt q" unfolding ‹tt q = min_term› by (rule tt_min_keys)
    with assms(3) show False by simp
  qed
  hence "tc q  0" by (rule tc_not_0)
  have "p = monomial (lc p) (lt p) + tail p" by (rule leading_monomial_tail)
  moreover from q  0 have "q = higher q (tt q) + monomial (tc q) (tt q)" by (rule trailing_monomial_higher)
  ultimately have pq: "p + q = (monomial (lc p) (lt p) + monomial (tc q) (tt q)) + (tail p + higher q (tt q))"
    (is "_ = (?m1 + ?m2) + ?b") by (simp add: algebra_simps)
  have keys_m1: "keys ?m1 = {lt p}"
  proof (rule keys_of_monomial, rule lc_not_0, rule)
    assume "p = 0"
    with assms(2) have "lt q t min_term" by (simp add: lt_def)
    with min_term_min[of "lt q"] show False by simp
  qed
  moreover from ‹tc q  0 have keys_m2: "keys ?m2 = {tt q}" by (rule keys_of_monomial)
  ultimately have keys_m1_m2: "keys (?m1 + ?m2) = {lt p, tt q}"
    using ‹lt p  tt q keys_plus_eqI[of ?m1 ?m2] by auto
  show ?thesis
  proof (rule ccontr)
    assume "?b  0"
    hence "keys ?b  {}" by simp
    then obtain t where "t  keys ?b" by blast
    hence t_in: "t  keys (tail p)  keys (higher q (tt q))"
      using Poly_Mapping.keys_add[of "tail p" "higher q (tt q)"] by blast
    hence "t  lt p"
    proof (rule, simp add: keys_tail, simp add: keys_higher, elim conjE)
      assume "t  keys q"
      hence "t t lt q" by (rule lt_max_keys)
      from this assms(2) show ?thesis by simp
    qed
    moreover from t_in have "t  tt q"
    proof (rule, simp add: keys_tail, elim conjE)
      assume "t  keys p"
      hence "tt p t t" by (rule tt_min_keys)
      with assms(3) show ?thesis by simp
    next
      assume "t  keys (higher q (tt q))"
      thus ?thesis by (auto simp only: keys_higher)
    qed
    ultimately have "t  keys (?m1 + ?m2)" by (simp add: keys_m1_m2)
    moreover from in_keys_plusI2[OF t  keys ?b this] have "t  keys (?m1 + ?m2)"
      by (simp only: keys_m1_m2 pq[symmetric] assms(1))
    ultimately show False ..
  qed
qed

subsection ‹Order Relation on Polynomials›

definition ord_strict_p :: "('t 0 'b::zero)  ('t 0 'b)  bool" (infixl "p" 50) where
  "p p q  (v. lookup p v = 0  lookup q v  0  (u. v t u  lookup p u = lookup q u))"

definition ord_p :: "('t 0 'b::zero)  ('t 0 'b)  bool" (infixl "p" 50) where
  "ord_p p q  (p p q  p = q)"

lemma ord_strict_pI:
  assumes "lookup p v = 0" and "lookup q v  0" and "u. v t u  lookup p u = lookup q u"
  shows "p p q"
  unfolding ord_strict_p_def using assms by blast

lemma ord_strict_pE:
  assumes "p p q"
  obtains v where "lookup p v = 0" and "lookup q v  0" and "u. v t u  lookup p u = lookup q u"
  using assms unfolding ord_strict_p_def by blast

lemma not_ord_pI:
  assumes "lookup p v  lookup q v" and "lookup p v  0" and "u. v t u  lookup p u = lookup q u"
  shows "¬ p p q"
proof
  assume "p p q"
  hence "p p q  p = q" by (simp only: ord_p_def)
  thus False
  proof
    assume "p p q"
    then obtain v' where 1: "lookup p v' = 0" and 2: "lookup q v'  0"
      and 3: "u. v' t u  lookup p u = lookup q u" by (rule ord_strict_pE, blast)
    from 1 2 have "lookup p v'  lookup q v'" by simp
    hence "¬ v t v'" using assms(3) by blast
    hence "v' t v  v' = v" by auto
    thus ?thesis
    proof
      assume "v' t v"
      hence "lookup p v = lookup q v" by (rule 3)
      with assms(1) show ?thesis ..
    next
      assume "v' = v"
      with assms(2) 1 show ?thesis by auto
    qed
  next
    assume "p = q"
    hence "lookup p v = lookup q v" by simp
    with assms(1) show ?thesis ..
  qed
qed

corollary not_ord_strict_pI:
  assumes "lookup p v  lookup q v" and "lookup p v  0" and "u. v t u  lookup p u = lookup q u"
  shows "¬ p p q"
proof -
  from assms have "¬ p p q" by (rule not_ord_pI)
  thus ?thesis by (simp add: ord_p_def)
qed

lemma ord_strict_higher: "p p q  (v. lookup p v = 0  lookup q v  0  higher p v = higher q v)"
  unfolding ord_strict_p_def higher_eq_iff ..

lemma ord_strict_p_asymmetric:
  assumes "p p q"
  shows "¬ q p p"
  using assms unfolding ord_strict_p_def
proof
  fix v1::'t
  assume "lookup p v1 = 0  lookup q v1  0  (u. v1 t u  lookup p u = lookup q u)"
  hence "lookup p v1 = 0" and "lookup q v1  0" and v1: "u. v1 t u  lookup p u = lookup q u"
    by auto
  show "¬ (v. lookup q v = 0  lookup p v  0  (u. v t u  lookup q u = lookup p u))"
  proof (intro notI, erule exE)
    fix v2::'t
    assume "lookup q v2 = 0  lookup p v2  0  (u. v2 t u  lookup q u = lookup p u)"
    hence "lookup q v2 = 0" and "lookup p v2  0" and v2: "u. v2 t u  lookup q u = lookup p u"
      by auto
    show False
    proof (rule ord_term_lin.linorder_cases)
      assume "v1 t v2"
      from v1[rule_format, OF this] ‹lookup q v2 = 0 ‹lookup p v2  0 show ?thesis by simp
    next
      assume "v1 = v2"
      thus ?thesis using ‹lookup p v1 = 0 ‹lookup p v2  0 by simp
    next
      assume "v2 t v1"
      from v2[rule_format, OF this] ‹lookup p v1 = 0 ‹lookup q v1  0 show ?thesis by simp
    qed
  qed
qed

lemma ord_strict_p_irreflexive: "¬ p p p"
  unfolding ord_strict_p_def
proof (intro notI, erule exE)
  fix v::'t
  assume "lookup p v = 0  lookup p v  0  (u. v t u  lookup p u = lookup p u)"
  hence "lookup p v = 0" and "lookup p v  0" by auto
  thus False by simp
qed

lemma ord_strict_p_transitive:
  assumes "a p b" and "b p c"
  shows "a p c"
proof -
  from a p b obtain v1 where "lookup a v1 = 0"
                            and "lookup b v1  0"
                            and v1[rule_format]: "(u. v1 t u  lookup a u = lookup b u)"
    unfolding ord_strict_p_def by auto
  from b p c obtain v2 where "lookup b v2 = 0"
                            and "lookup c v2  0"
                            and v2[rule_format]: "(u. v2 t u  lookup b u = lookup c u)"
    unfolding ord_strict_p_def by auto
  show "a p c"
  proof (rule ord_term_lin.linorder_cases)
    assume "v1 t v2"
    show ?thesis unfolding ord_strict_p_def
    proof
      show "lookup a v2 = 0  lookup c v2  0  (u. v2 t u  lookup a u = lookup c u)"
      proof (intro conjI allI impI)
        from ‹lookup b v2 = 0 v1[OF v1 t v2] show "lookup a v2 = 0" by simp
      next
        from ‹lookup c v2  0 show "lookup c v2  0" .
      next
        fix u
        assume "v2 t u"
        from ord_term_lin.less_trans[OF v1 t v2 this] have "v1 t u" .
        from v2[OF v2 t u] v1[OF this] show "lookup a u = lookup c u" by simp
      qed
    qed
  next
    assume "v2 t v1"
    show ?thesis unfolding ord_strict_p_def
    proof
      show "lookup a v1 = 0  lookup c v1  0  (u. v1 t u  lookup a u = lookup c u)"
      proof (intro conjI allI impI)
        from ‹lookup a v1 = 0 show "lookup a v1 = 0" .
      next
        from ‹lookup b v1  0 v2[OF v2 t v1] show "lookup c v1  0" by simp
      next
        fix u
        assume "v1 t u"
        from ord_term_lin.less_trans[OF v2 t v1 this] have "v2 t u" .
        from v1[OF v1 t u] v2[OF this] show "lookup a u = lookup c u" by simp
      qed
    qed
  next
    assume "v1 = v2"
    thus ?thesis using ‹lookup b v1  0 ‹lookup b v2 = 0 by simp
  qed
qed

sublocale order ord_p ord_strict_p
proof (intro order_strictI)
  fix p q :: "'t 0 'b"
  show "(p p q) = (p p q  p = q)" unfolding ord_p_def ..
next
  fix p q :: "'t 0 'b"
  assume "p p q"
  thus "¬ q p p" by (rule ord_strict_p_asymmetric)
next
  fix p::"'t 0 'b"
  show "¬ p p p" by (fact ord_strict_p_irreflexive)
next
  fix a b c :: "'t 0 'b"
  assume "a p b" and "b p c"
  thus "a p c" by (rule ord_strict_p_transitive)
qed

lemma ord_p_zero_min: "0 p p"
  unfolding ord_p_def ord_strict_p_def
proof (cases "p = 0")
  case True
  thus "(v. lookup 0 v = 0  lookup p v  0  (u. v t u  lookup 0 u = lookup p u))  0 = p"
    by auto
next
  case False
  show "(v. lookup 0 v = 0  lookup p v  0  (u. v t u  lookup 0 u = lookup p u))  0 = p"
  proof
    show "(v. lookup 0 v = 0  lookup p v  0  (u. v t u  lookup 0 u = lookup p u))"
    proof
      show "lookup 0 (lt p) = 0  lookup p (lt p)  0  (u. (lt p) t u  lookup 0 u = lookup p u)"
      proof (intro conjI allI impI)
        show "lookup 0 (lt p) = 0" by (transfer, simp)
      next
        from lc_not_0[OF False] show "lookup p (lt p)  0" unfolding lc_def .
      next
        fix u
        assume "lt p t u"
        hence "¬ u t lt p" by simp
        hence "lookup p u = 0" using lt_max[of p u] by metis
        thus "lookup 0 u = lookup p u" by simp
      qed
    qed
  qed
qed

lemma lt_ord_p:
  assumes "lt p t lt q"
  shows "p p q"
proof -
  have "q  0"
  proof
    assume "q = 0"
    with assms have "lt p t min_term" by (simp add: lt_def)
    with min_term_min[of "lt p"] show False by simp
  qed
  show ?thesis unfolding ord_strict_p_def
  proof (intro exI conjI allI impI)
    show "lookup p (lt q) = 0"
    proof (rule ccontr)
      assume "lookup p (lt q)  0"
      from lt_max[OF this] ‹lt p t lt q show False by simp
    qed
  next
    from lc_not_0[OF q  0] show "lookup q (lt q)  0" unfolding lc_def .
  next
    fix u
    assume "lt q t u"
    hence "lt p t u" using ‹lt p t lt q by simp
    have c1: "lookup q u = 0"
    proof (rule ccontr)
      assume "lookup q u  0"
      from lt_max[OF this] ‹lt q t u show False by simp
    qed
    have c2: "lookup p u = 0"
    proof (rule ccontr)
      assume "lookup p u  0"
      from lt_max[OF this] ‹lt p t u show False by simp
    qed
    from c1 c2 show "lookup p u = lookup q u" by simp
  qed
qed

lemma ord_p_lt:
  assumes "p p q"
  shows "lt p t lt q"
proof (rule ccontr)
  assume "¬ lt p t lt q"
  hence "lt q t lt p" by simp
  from lt_ord_p[OF this] p p q show False by simp
qed

lemma ord_p_tail:
  assumes "p  0" and "lt p = lt q" and "p p q"
  shows "tail p p tail q"
  using assms unfolding ord_strict_p_def
proof -
  assume "p  0" and "lt p = lt q"
    and "v. lookup p v = 0  lookup q v  0  (u. v t u  lookup p u = lookup q u)"
  then obtain v where "lookup p v = 0"
                  and "lookup q v  0"
                  and a: "u. v t u  lookup p u = lookup q u" by auto
  from lt_max[OF ‹lookup q v  0] ‹lt p = lt q have "v t lt p  v = lt p" by auto
  hence "v t lt p"
  proof
    assume "v t lt p"
    thus ?thesis .
  next
    assume "v = lt p"
    thus ?thesis using lc_not_0[OF p  0] ‹lookup p v = 0 unfolding lc_def by auto
  qed
  have pt: "lookup (tail p) v = lookup p v" using lookup_tail[of p v] v t lt p by simp
  have "q  0"
  proof
    assume "q = 0"
    hence  "p p 0" using p p q by simp
    hence "¬ 0 p p" by auto
    thus False using ord_p_zero_min[of p] by simp
  qed
  have qt: "lookup (tail q) v = lookup q v"
    using lookup_tail[of q v] v t lt p ‹lt p = lt q by simp
  show "w. lookup (tail p) w = 0  lookup (tail q) w  0 
        (u. w t u  lookup (tail p) u = lookup (tail q) u)"
  proof (intro exI conjI allI impI)
    from pt ‹lookup p v = 0 show "lookup (tail p) v = 0" by simp
  next
    from qt ‹lookup q v  0 show "lookup (tail q) v  0" by simp
  next
    fix u
    assume "v t u"
    from a[rule_format, OF v t u] lookup_tail[of p u] lookup_tail[of q u]
      ‹lt p = lt q show "lookup (tail p) u = lookup (tail q) u" by simp
  qed
qed

lemma tail_ord_p:
  assumes "p  0"
  shows "tail p p p"
proof (cases "tail p = 0")
  case True
  with ord_p_zero_min[of p] p  0 show ?thesis by simp
next
  case False
  from lt_tail[OF False] show ?thesis by (rule lt_ord_p)
qed

lemma higher_lookup_eq_zero:
  assumes pt: "lookup p v = 0" and hp: "higher p v = 0" and le: "q p p"
  shows "(lookup q v = 0)  (higher q v) = 0"
using le unfolding ord_p_def
proof
  assume "q p p"
  thus ?thesis unfolding ord_strict_p_def
  proof
    fix w
    assume "lookup q w = 0  lookup p w  0  (u. w t u  lookup q u = lookup p u)"
    hence qs: "lookup q w = 0" and ps: "lookup p w  0" and u: "u. w t u  lookup q u = lookup p u"
      by auto
    from hp have pu: "u. v t u  lookup p u = 0" by (simp only: higher_eq_zero_iff)
    from pu[rule_format, of w] ps have "¬ v t w" by auto
    hence "w t v" by simp
    hence "w t v  w = v" by auto
    hence st: "w t v"
    proof (rule disjE, simp_all)
      assume "w = v"
      from this pt ps show False by simp
    qed
    show ?thesis
    proof
      from u[rule_format, OF st] pt show "lookup q v = 0" by simp
    next
      have "u. v t u  lookup q u = 0"
      proof (intro allI, intro impI)
        fix u
        assume "v t u"
        from this st have "w t u" by simp
        from u[rule_format, OF this] pu[rule_format, OF v t u] show "lookup q u = 0" by simp
      qed
      thus "higher q v = 0" by (simp only: higher_eq_zero_iff)
    qed
  qed
next
  assume "q = p"
  thus ?thesis using assms by simp
qed

lemma ord_strict_p_recI:
  assumes "lt p = lt q" and "lc p = lc q" and tail: "tail p p tail q"
  shows "p p q"
proof -
  from tail obtain v where pt: "lookup (tail p) v = 0"
                      and qt: "lookup (tail q) v  0"
                      and a: "u. v t u  lookup (tail p) u = lookup (tail q) u"
    unfolding ord_strict_p_def by auto
  from qt lookup_zero[of v] have "tail q  0" by auto
  from lt_max[OF qt] lt_tail[OF this] have "v t lt q" by simp
  hence "v t lt p" using ‹lt p = lt q by simp
  show ?thesis unfolding ord_strict_p_def
  proof (rule exI[of _ v], intro conjI allI impI)
    from lookup_tail[of p v] v t lt p pt show "lookup p v = 0" by simp
  next
    from lookup_tail[of q v] v t lt q qt show "lookup q v  0" by simp
  next
    fix u
    assume "v t u"
    from this a have s: "lookup (tail p) u = lookup (tail q) u" by simp
    show "lookup p u = lookup q u"
    proof (cases "u = lt p")
      case True
      from True ‹lc p = lc q ‹lt p = lt q show ?thesis unfolding lc_def by simp
    next
      case False
      from False s lookup_tail_2[of p u] lookup_tail_2[of q u] ‹lt p = lt q show ?thesis by simp
    qed
  qed
qed

lemma ord_strict_p_recE1:
  assumes "p p q"
  shows "q  0"
proof
  assume "q = 0"
  from this assms ord_p_zero_min[of p] show False by simp
qed

lemma ord_strict_p_recE2:
  assumes "p  0" and "p p q" and "lt p = lt q"
  shows "lc p = lc q"
proof -
  from p p q obtain v where pt: "lookup p v = 0"
                          and qt: "lookup q v  0"
                          and a: "u. v t u  lookup p u = lookup q u"
    unfolding ord_strict_p_def by auto
  show ?thesis
  proof (cases "v t lt p")
    case True
    from this a have "lookup p (lt p) = lookup q (lt p)" by simp
    thus ?thesis using ‹lt p = lt q unfolding lc_def by simp
  next
    case False
    from this lt_max[OF qt] ‹lt p = lt q have "v = lt p" by simp
    from this lc_not_0[OF p  0] pt show ?thesis unfolding lc_def by auto
  qed
qed

lemma ord_strict_p_rec [code]:
  "p p q =
  (q  0 
    (p = 0 
      (let v1 = lt p; v2 = lt q in
        (v1 t v2  (v1 = v2  lookup p v1 = lookup q v2  lower p v1 p lower q v2))
      )
    )
   )"
  (is "?L = ?R")
proof
  assume ?L
  show ?R
  proof (intro conjI, rule ord_strict_p_recE1, fact)
    have "((lt p = lt q  lc p = lc q  tail p p tail q)  lt p t lt q)  p = 0"
    proof (intro disjCI)
      assume "p  0" and nl: "¬ lt p t lt q"
      from ?L have "p p q" by simp
      from ord_p_lt[OF this] nl have "lt p = lt q" by simp
      show "lt p = lt q  lc p = lc q  tail p p tail q"
        by (intro conjI, fact, rule ord_strict_p_recE2, fact+, rule ord_p_tail, fact+)
    qed
    thus "p = 0 
            (let v1 = lt p; v2 = lt q in
              (v1 t v2  v1 = v2  lookup p v1 = lookup q v2  lower p v1 p lower q v2)
            )"
      unfolding lc_def tail_def by auto
  qed
next
  assume ?R
  hence "q  0"
    and dis: "p = 0 
                (let v1 = lt p; v2 = lt q in
                  (v1 t v2  v1 = v2  lookup p v1 = lookup q v2  lower p v1 p lower q v2)
                )"
    by simp_all
  show ?L
  proof (cases "p = 0")
    assume "p = 0"
    hence "p p q" using ord_p_zero_min[of q] by simp
    thus ?thesis using p = 0 q  0 by simp
  next
    assume "p  0"
    hence "let v1 = lt p; v2 = lt q in
            (v1 t v2  v1 = v2  lookup p v1 = lookup q v2  lower p v1 p lower q v2)"
      using dis by simp
    hence "lt p t lt q  (lt p = lt q  lc p = lc q  tail p p tail q)"
      unfolding lc_def tail_def by (simp add: Let_def)
    thus ?thesis
    proof
      assume "lt p t lt q"
      from lt_ord_p[OF this] show ?thesis .
    next
      assume "lt p = lt q  lc p = lc q  tail p p tail q"
      hence "lt p = lt q" and "lc p = lc q" and "tail p p tail q" by simp_all
      thus ?thesis by (rule ord_strict_p_recI)
    qed
  qed
qed

lemma ord_strict_p_monomial_iff: "p p monomial c v  (c  0  (p = 0  lt p t v))"
proof -
  from ord_p_zero_min[of "tail p"] have *: "¬ tail p p 0" by auto
  show ?thesis
    by (simp add: ord_strict_p_rec[of p] Let_def tail_def[symmetric] lc_def[symmetric]
        monomial_0_iff tail_monomial *, simp add: lt_monomial cong: conj_cong)
qed

corollary ord_strict_p_monomial_plus:
  assumes "p p monomial c v" and "q p monomial c v"
  shows "p + q p monomial c v"
proof -
  from assms(1) have "c  0" and "p = 0  lt p t v" by (simp_all add: ord_strict_p_monomial_iff)
  from this(2) show ?thesis
  proof
    assume "p = 0"
    with assms(2) show ?thesis by simp
  next
    assume "lt p t v"
    from assms(2) have "q = 0  lt q t v" by (simp add: ord_strict_p_monomial_iff)
    thus ?thesis
    proof
      assume "q = 0"
      with assms(1) show ?thesis by simp
    next
      assume "lt q t v"
      with ‹lt p t v have "lt (p + q) t v"
        using lt_plus_le_max ord_term_lin.dual_order.strict_trans2 ord_term_lin.max_less_iff_conj
        by blast 
      with c  0 show ?thesis by (simp add: ord_strict_p_monomial_iff)
    qed
  qed
qed

lemma ord_strict_p_monom_mult:
  assumes "p p q" and "c  (0::'b::semiring_no_zero_divisors)"
  shows "monom_mult c t p p monom_mult c t q"
proof -
  from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v  0"
    and 3: "u. v t u  lookup p u = lookup q u" unfolding ord_strict_p_def by auto
  show ?thesis unfolding ord_strict_p_def
  proof (intro exI conjI allI impI)
    from 1 show "lookup (monom_mult c t p) (t  v) = 0" by (simp add: lookup_monom_mult_plus)
  next
    from 2 assms(2) show "lookup (monom_mult c t q) (t  v)  0" by (simp add: lookup_monom_mult_plus)
  next
    fix u
    assume "t  v t u"
    show "lookup (monom_mult c t p) u = lookup (monom_mult c t q) u"
    proof (cases "t addsp u")
      case True
      then obtain w where u: "u = t  w" ..
      from t  v t u have "v t w" unfolding u by (rule ord_term_strict_canc)
      hence "lookup p w = lookup q w" by (rule 3)
      thus ?thesis by (simp add: u lookup_monom_mult_plus)
    next
      case False
      thus ?thesis by (simp add: lookup_monom_mult)
    qed
  qed
qed

lemma ord_strict_p_plus:
  assumes "p p q" and "keys r  keys q = {}"
  shows "p + r p q + r"
proof -
  from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v  0"
    and 3: "u. v t u  lookup p u = lookup q u" unfolding ord_strict_p_def by auto
  have eq: "lookup r v = 0"
    by (meson "2" assms(2) disjoint_iff_not_equal in_keys_iff)
  show ?thesis unfolding ord_strict_p_def
  proof (intro exI conjI allI impI, simp_all add: lookup_add)
    from 1 show "lookup p v + lookup r v = 0" by (simp add: eq)
  next
    from 2 show "lookup q v + lookup r v  0" by (simp add: eq)
  next
    fix u
    assume "v t u"
    hence "lookup p u = lookup q u" by (rule 3)
    thus "lookup p u + lookup r u = lookup q u + lookup r u" by simp
  qed
qed

lemma poly_mapping_tail_induct [case_names 0 tail]:
  assumes "P 0" and "p. p  0  P (tail p)  P p"
  shows "P p"
proof (induct "card (keys p)" arbitrary: p)
  case 0
  with finite_keys[of p] have "keys p = {}" by simp
  hence "p = 0" by simp
  from P 0 show ?case unfolding p = 0 .
next
  case ind: (Suc n)
  from ind(2) have "keys p  {}" by auto
  hence "p  0" by simp
  thus ?case
  proof (rule assms(2))
    show "P (tail p)"
    proof (rule ind(1))
      from p  0 have "lt p  keys p" by (rule lt_in_keys)
      hence "card (keys (tail p)) = card (keys p) - 1" by (simp add: keys_tail)
      also have "... = n" unfolding ind(2)[symmetric] by simp
      finally show "n = card (keys (tail p))" by simp
    qed
  qed
qed

lemma poly_mapping_neqE:
  assumes "p  q"
  obtains v where "v  keys p  keys q" and "lookup p v  lookup q v"
    and "u. v t u  lookup p u = lookup q u"
proof -
  let ?A = "{v. lookup p v  lookup q v}"
  define v where "v = ord_term_lin.Max ?A"
  have "?A  keys p  keys q"
    using UnI2 in_keys_iff by fastforce
  also have "finite ..." by (rule finite_UnI) (fact finite_keys)+
  finally(finite_subset) have fin: "finite ?A" .
  moreover have "?A  {}"
  proof
    assume "?A = {}"
    hence "p = q"
      using poly_mapping_eqI by fastforce
    with assms show False ..
  qed
  ultimately have "v  ?A" unfolding v_def by (rule ord_term_lin.Max_in)
  show ?thesis
  proof
    from ?A  keys p  keys q v  ?A show "v  keys p  keys q" ..
  next
    from v  ?A show "lookup p v  lookup q v" by simp
  next
    fix u
    assume "v t u"
    show "lookup p u = lookup q u"
    proof (rule ccontr)
      assume "lookup p u  lookup q u"
      hence "u  ?A" by simp
      with fin have "u t v" unfolding v_def by (rule ord_term_lin.Max_ge)
      with v t u show False by simp
    qed
  qed
qed

subsection ‹Monomials›

lemma keys_monomial:
  assumes "is_monomial p"
  shows "keys p = {lt p}"
  using assms by (metis is_monomial_monomial lt_monomial keys_of_monomial)

lemma monomial_eq_itself:
  assumes "is_monomial p"
  shows "monomial (lc p) (lt p) = p"
proof -
  from assms have "p  0" by (rule monomial_not_0)
  hence "lc p  0" by (rule lc_not_0)
  hence keys1: "keys (monomial (lc p) (lt p)) = {lt p}" by (rule keys_of_monomial)
  show ?thesis
    by (rule poly_mapping_keys_eqI, simp only: keys_monomial[OF assms] keys1,
        simp only: keys1 lookup_single Poly_Mapping.when_def, auto simp add: lc_def)
qed

lemma lt_eq_min_term_monomial:
  assumes "lt p = min_term"
  shows "monomial (lc p) min_term = p"
proof (rule poly_mapping_eqI)
  fix v
  from min_term_min[of v] have "v = min_term  min_term t v" by auto
  thus "lookup (monomial (lc p) min_term) v = lookup p v"
  proof
    assume "v = min_term"
    thus ?thesis by (simp add: lookup_single lc_def assms)
  next
    assume "min_term t v"
    moreover have "v  keys p"
    proof
      assume "v  keys p"
      hence "v t lt p" by (rule lt_max_keys)
      with ‹min_term t v show False by (simp add: assms)
    qed
    ultimately show ?thesis by (simp add: lookup_single in_keys_iff)
  qed
qed

lemma is_monomial_monomial_ordered:
  assumes "is_monomial p"
  obtains c v where "c  0" and "lc p = c" and "lt p = v" and "p = monomial c v"
proof -
  from assms obtain c v where "c  0" and p_eq: "p = monomial c v" by (rule is_monomial_monomial)
  note this(1)
  moreover have "lc p = c" unfolding p_eq by (rule lc_monomial)
  moreover from c  0 have "lt p = v" unfolding p_eq by (rule lt_monomial)
  ultimately show ?thesis using p_eq ..
qed

lemma monomial_plus_not_0:
  assumes "c  0" and "lt p t v"
  shows "monomial c v + p  0"
proof
  assume "monomial c v + p = 0"
  hence "0 = lookup (monomial c v + p) v" by simp
  also have "... = c + lookup p v" by (simp add: lookup_add)
  also have "... = c"
  proof -
    from assms(2) have "¬ v t lt p" by simp
    with lt_max[of p v] have "lookup p v = 0" by blast
    thus ?thesis by simp
  qed
  finally show False using c  0 by simp
qed

lemma lt_monomial_plus:
  assumes "c  (0::'b::comm_monoid_add)" and "lt p t v"
  shows "lt (monomial c v + p) = v"
proof -
  have eq: "lt (monomial c v) = v" by (simp only: lt_monomial[OF c  0])
  moreover have "lt (p + monomial c v) = lt (monomial c v)" by (rule lt_plus_eqI, simp only: eq, fact)
  ultimately show ?thesis by (simp add: add.commute)
qed

lemma lc_monomial_plus:
  assumes "c  (0::'b::comm_monoid_add)" and "lt p t v"
  shows "lc (monomial c v + p) = c"
proof -
  from assms(2) have "¬ v t lt p" by simp
  with lt_max[of p v] have "lookup p v = 0" by blast
  thus ?thesis by (simp add: lc_def lt_monomial_plus[OF assms] lookup_add)
qed

lemma tt_monomial_plus:
  assumes "p  (0::_ 0 'b::comm_monoid_add)" and "lt p t v"
  shows "tt (monomial c v + p) = tt p"
proof (cases "c = 0")
  case True
  thus ?thesis by (simp add: monomial_0I)
next
  case False
  have eq: "tt (monomial c v) = v" by (simp only: tt_monomial[OF c  0])
  moreover have "tt (p + monomial c v) = tt p"
  proof (rule tt_plus_eqI, fact, simp only: eq)
    from lt_ge_tt[of p] assms(2) show "tt p t v" by simp
  qed
  ultimately show ?thesis by (simp add: ac_simps)
qed

lemma tc_monomial_plus:
  assumes "p  (0::_ 0 'b::comm_monoid_add)" and "lt p t v"
  shows "tc (monomial c v + p) = tc p"
proof (simp add: tc_def tt_monomial_plus[OF assms] lookup_add lookup_single Poly_Mapping.when_def,
    rule impI)
  assume "v = tt p"
  with assms(2) have "lt p t tt p" by simp
  with lt_ge_tt[of p] show "c + lookup p (tt p) = lookup p (tt p)" by simp
qed

lemma tail_monomial_plus:
  assumes "c  (0::'b::comm_monoid_add)" and "lt p t v"
  shows "tail (monomial c v + p) = p" (is "tail ?q = _")
proof -
  from assms have "lt ?q = v" by (rule lt_monomial_plus)
  moreover have "lower (monomial c v) v = 0"
    by (simp add: lower_eq_zero_iff', rule disjI2, simp add: tt_monomial[OF c  0])
  ultimately show ?thesis by (simp add: tail_def lower_plus lower_id_iff, intro disjI2 assms(2))
qed

subsection ‹Lists of Keys›

text ‹In algorithms one very often needs to compute the sorted list of all terms appearing
  in a list of polynomials.›

definition pps_to_list :: "'t set  't list" where
  "pps_to_list S = rev (ord_term_lin.sorted_list_of_set S)"

definition keys_to_list :: "('t 0 'b::zero)  't list"
  where "keys_to_list p = pps_to_list (keys p)"

definition Keys_to_list :: "('t 0 'b::zero) list  't list"
  where "Keys_to_list ps = fold (λp ts. merge_wrt (≻t) (keys_to_list p) ts) ps []"

text ‹Function @{const pps_to_list} turns finite sets of terms into sorted lists, where the
  lists are sorted descending (i.\,e. greater elements come before smaller ones).›

lemma distinct_pps_to_list: "distinct (pps_to_list S)"
  unfolding pps_to_list_def distinct_rev by (rule ord_term_lin.distinct_sorted_list_of_set)

lemma set_pps_to_list:
  assumes "finite S"
  shows "set (pps_to_list S) = S"
  unfolding pps_to_list_def set_rev using assms by simp

lemma length_pps_to_list: "length (pps_to_list S) = card S"
proof (cases "finite S")
  case True
  from distinct_card[OF distinct_pps_to_list] have "length (pps_to_list S) = card (set (pps_to_list S))"
    by simp
  also from True have "... = card S" by (simp only: set_pps_to_list)
  finally show ?thesis .
next
  case False
  thus ?thesis by (simp add: pps_to_list_def)
qed

lemma pps_to_list_sorted_wrt: "sorted_wrt (≻t) (pps_to_list S)"
proof -
  have "sorted_wrt (≽t) (pps_to_list S)"
  proof -
    have tr: "transp (≼t)" using transp_def by fastforce
    have *: "(λx y. y t x) = (≼t)" by simp
    show ?thesis
      by (simp only: * pps_to_list_def sorted_wrt_rev ord_term_lin.sorted_sorted_wrt[symmetric],
          rule ord_term_lin.sorted_sorted_list_of_set)
  qed
  with distinct_pps_to_list have "sorted_wrt (λx y. x t y  x  y) (pps_to_list S)"
    by (rule distinct_sorted_wrt_imp_sorted_wrt_strict)
  moreover have "(≻t) = (λx y. x t y  x  y)"
    using ord_term_lin.dual_order.order_iff_strict by auto
  ultimately show ?thesis by simp
qed

lemma pps_to_list_nth_leI:
  assumes "j  i" and "i < card S"
  shows "(pps_to_list S) ! i t (pps_to_list S) ! j"
proof (cases "j = i")
  case True
  show ?thesis by (simp add: True)
next
  case False
  with assms(1) have "j < i" by simp
  let ?ts = "pps_to_list S"
  from pps_to_list_sorted_wrt j < i have "(≺t)¯¯ (?ts ! j) (?ts ! i)"
  proof (rule sorted_wrt_nth_less)
    from assms(2) show "i < length ?ts" by (simp only: length_pps_to_list)
  qed
  thus ?thesis by simp
qed

lemma pps_to_list_nth_lessI:
  assumes "j < i" and "i < card S"
  shows "(pps_to_list S) ! i t (pps_to_list S) ! j"
proof -
  let ?ts = "pps_to_list S"
  from assms(1) have "j  i" and "i  j" by simp_all
  with assms(2) have "i < length ?ts" and "j < length ?ts" by (simp_all only: length_pps_to_list)
  show ?thesis
  proof (rule ord_term_lin.neq_le_trans)
    from i  j show "?ts ! i  ?ts ! j"
      by (simp add: nth_eq_iff_index_eq[OF distinct_pps_to_list i < length ?ts j < length ?ts])
  next
    from j  i assms(2) show "?ts ! i t ?ts ! j" by (rule pps_to_list_nth_leI)
  qed
qed

lemma pps_to_list_nth_leD:
  assumes "(pps_to_list S) ! i t (pps_to_list S) ! j" and "j < card S"
  shows "j  i"
proof (rule ccontr)
  assume "¬ j  i"
  hence "i < j" by simp
  from this j < card S have "(pps_to_list S) ! j t (pps_to_list S) ! i" by (rule pps_to_list_nth_lessI)
  with assms(1) show False by simp
qed

lemma pps_to_list_nth_lessD:
  assumes "(pps_to_list S) ! i t (pps_to_list S) ! j" and "j < card S"
  shows "j < i"
proof (rule ccontr)
  assume "¬ j < i"
  hence "i  j" by simp
  from this j < card S have "(pps_to_list S) ! j t (pps_to_list S) ! i" by (rule pps_to_list_nth_leI)
  with assms(1) show False by simp
qed

lemma set_keys_to_list: "set (keys_to_list p) = keys p"
  by (simp add: keys_to_list_def set_pps_to_list)

lemma length_keys_to_list: "length (keys_to_list p) = card (keys p)"
  by (simp only: keys_to_list_def length_pps_to_list)

lemma keys_to_list_zero [simp]: "keys_to_list 0 = []"
  by (simp add: keys_to_list_def pps_to_list_def)

lemma Keys_to_list_Nil [simp]: "Keys_to_list [] = []"
  by (simp add: Keys_to_list_def)

lemma set_Keys_to_list: "set (Keys_to_list ps) = Keys (set ps)"
proof -
  have "set (Keys_to_list ps) = (pset ps. set (keys_to_list p))  set []"
    unfolding Keys_to_list_def by (rule set_fold, simp only: set_merge_wrt)
  also have "... = Keys (set ps)" by (simp add: Keys_def set_keys_to_list)
  finally show ?thesis .
qed

lemma Keys_to_list_sorted_wrt_aux:
  assumes "sorted_wrt (≻t) ts"
  shows "sorted_wrt (≻t) (fold (λp ts. merge_wrt (≻t) (keys_to_list p) ts) ps ts)"
  using assms
proof (induct ps arbitrary: ts)
  case Nil
  thus ?case by simp
next
  case (Cons p ps)
  show ?case
  proof (simp only: fold.simps o_def, rule Cons(1), rule sorted_merge_wrt)
    show "transp (≻t)" unfolding transp_def by fastforce
  next
    fix x y :: 't
    assume "x  y"
    thus "x t y  y t x" by auto
  next
    show "sorted_wrt (≻t) (keys_to_list p)" unfolding keys_to_list_def
      by (fact pps_to_list_sorted_wrt)
  qed fact
qed

corollary Keys_to_list_sorted_wrt: "sorted_wrt (≻t) (Keys_to_list ps)"
  unfolding Keys_to_list_def
proof (rule Keys_to_list_sorted_wrt_aux)
  show "sorted_wrt (≻t) []" by simp
qed

corollary distinct_Keys_to_list: "distinct (Keys_to_list ps)"
proof (rule distinct_sorted_wrt_irrefl)
  show "irreflp (≻t)" by (simp add: irreflp_def)
next
  show "transp (≻t)" unfolding transp_def by fastforce
next
  show "sorted_wrt (≻t) (Keys_to_list ps)" by (fact Keys_to_list_sorted_wrt)
qed

lemma length_Keys_to_list: "length (Keys_to_list ps) = card (Keys (set ps))"
proof -
  from distinct_Keys_to_list have "card (set (Keys_to_list ps)) = length (Keys_to_list ps)"
    by (rule distinct_card)
  thus ?thesis by (simp only: set_Keys_to_list)
qed

lemma Keys_to_list_eq_pps_to_list: "Keys_to_list ps = pps_to_list (Keys (set ps))"
  using _ Keys_to_list_sorted_wrt distinct_Keys_to_list pps_to_list_sorted_wrt distinct_pps_to_list
proof (rule sorted_wrt_distinct_set_unique)
  show "antisymp (≻t)" unfolding antisymp_def by fastforce
next
  from finite_set have fin: "finite (Keys (set ps))" by (rule finite_Keys)
  show "set (Keys_to_list ps) = set (pps_to_list (Keys (set ps)))"
    by (simp add: set_Keys_to_list set_pps_to_list[OF fin])
qed

subsection ‹Multiplication›

lemma in_keys_mult_scalar_le:
  assumes "v  keys (p  q)"
  shows "v t punit.lt p  lt q"
proof -
  from assms obtain t u where "t  keys p" and "u  keys q" and "v = t  u"
    by (rule in_keys_mult_scalarE)
  from t  keys p have "t  punit.lt p" by (rule punit.lt_max_keys)
  from u  keys q have "u t lt q" by (rule lt_max_keys)
  hence "v t t  lt q" unfolding v = t  u by (rule splus_mono)
  also from t  punit.lt p have "... t punit.lt p  lt q" by (rule splus_mono_left)
  finally show ?thesis .
qed

lemma in_keys_mult_scalar_ge:
  assumes "v  keys (p  q)"
  shows "punit.tt p  tt q t v"
proof -
  from assms obtain t u where "t  keys p" and "u  keys q" and "v = t  u"
    by (rule in_keys_mult_scalarE)
  from t  keys p have "punit.tt p  t" by (rule punit.tt_min_keys)
  from u  keys q have "tt q t u" by (rule tt_min_keys)
  hence "punit.tt p  tt q t punit.tt p  u" by (rule splus_mono)
  also from ‹punit.tt p  t have "... t v" unfolding v = t  u by (rule splus_mono_left)
  finally show ?thesis .
qed

lemma (in ordered_term) lookup_mult_scalar_lt_lt:
  "lookup (p  q) (punit.lt p  lt q) = punit.lc p * lc q"
proof (induct p rule: punit.poly_mapping_tail_induct)
  case 0
  show ?case by simp
next
  case step: (tail p)
  from step(1) have "punit.lc p  0" by (rule punit.lc_not_0)
  let ?t = "punit.lt p  lt q"
  show ?case
  proof (cases "is_monomial p")
    case True
    then obtain c t where "c  0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
      by (rule punit.is_monomial_monomial_ordered)
    hence "p  q = monom_mult (punit.lc p) (punit.lt p) q" by (simp add: mult_scalar_monomial)
    thus ?thesis by (simp add: lookup_monom_mult_plus lc_def)
  next
    case False
    have "punit.lt (punit.tail p)  punit.lt p"
    proof (simp add: punit.tail_def punit.lt_lower_eq_iff, rule)
      assume "punit.lt p = 0"
      have "keys p  {punit.lt p}"
      proof (rule, simp)
        fix s
        assume "s  keys p"
        hence "s  punit.lt p" by (rule punit.lt_max_keys)
        moreover have "punit.lt p  s" unfolding ‹punit.lt p = 0 by (rule zero_min)
        ultimately show "s = punit.lt p" by simp
      qed
      hence "card (keys p) = 0  card (keys p) = 1" using subset_singletonD by fastforce
      thus False
      proof
        assume "card (keys p) = 0"
        hence "p = 0" by (meson card_0_eq keys_eq_empty finite_keys) 
        with step(1) show False ..
      next
        assume "card (keys p) = 1"
        with False show False unfolding is_monomial_def ..
      qed
    qed
    with punit.lt_lower[of p "punit.lt p"] have "punit.lt (punit.tail p)  punit.lt p"
      by (simp add: punit.tail_def)
    have eq: "lookup ((punit.tail p)  q) ?t = 0"
    proof (rule ccontr)
      assume "lookup ((punit.tail p)  q) ?t  0"
      hence "?t t punit.lt (punit.tail p)  lt q"
        by (meson in_keys_mult_scalar_le lookup_not_eq_zero_eq_in_keys) 
      hence "punit.lt p  punit.lt (punit.tail p)" by (rule ord_term_canc_left)
      also have "...  punit.lt p" by fact
      finally show False ..
    qed
    from step(2) have "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = punit.lc p * lc q"
      by (simp only: lookup_monom_mult_plus lc_def)
    thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
  qed
qed

lemma lookup_mult_scalar_tt_tt: "lookup (p  q) (punit.tt p  tt q) = punit.tc p * tc q"
proof (induct p rule: punit.poly_mapping_tail_induct)
  case 0
  show ?case by simp
next
  case step: (tail p)
  from step(1) have "punit.lc p  0" by (rule punit.lc_not_0)
  let ?t = "punit.tt p  tt q"
  show ?case
  proof (cases "is_monomial p")
    case True
    then obtain c t where "c  0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
      by (rule punit.is_monomial_monomial_ordered)
    from c  0 have "punit.tt p = t" and "punit.tc p = c" by (simp_all add: p_eq punit.tt_monomial)
    with p_eq have "p  q = monom_mult (punit.tc p) (punit.tt p) q" by (simp add: mult_scalar_monomial)
    thus ?thesis by (simp add: lookup_monom_mult_plus tc_def)
  next
    case False
    from step(1) have "keys p  {}" by simp
    with finite_keys have "card (keys p)  0" by auto
    with False have "2  card (keys p)" unfolding is_monomial_def by linarith
    then obtain s t where "s  keys p" and "t  keys p" and "s  t"
      by (metis (mono_tags, lifting) card.empty card.infinite card_insert_disjoint card_mono empty_iff
          finite.emptyI insertCI lessI not_less numeral_2_eq_2 ordered_powerprod_lin.infinite_growing
          ordered_powerprod_lin.neqE preorder_class.less_le_trans subsetI)
    from this(1) this(3) have "punit.tt p  t" by (rule punit.tt_less)
    also from t  keys p have "t  punit.lt p" by (rule punit.lt_max_keys)
    finally have "punit.tt p  punit.lt p" .
    hence tt_tail: "punit.tt (punit.tail p) = punit.tt p" and tc_tail: "punit.tc (punit.tail p) = punit.tc p"
      unfolding punit.tail_def by (rule punit.tt_lower, rule punit.tc_lower)
    have eq: "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = 0"
    proof (rule ccontr)
      assume "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t  0"
      hence "punit.lt p  tt q t ?t"
        by (meson in_keys_iff in_keys_monom_mult_ge) 
      hence "punit.lt p  punit.tt p" by (rule ord_term_canc_left)
      also have "...  punit.lt p" by fact
      finally show False ..
    qed
    from step(2) have "lookup (punit.tail p  q) ?t = punit.tc p * tc q" by (simp only: tt_tail tc_tail)
    thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
  qed
qed

lemma lt_mult_scalar:
  assumes "p  0" and "q  (0::'t 0 'b::semiring_no_zero_divisors)"
  shows "lt (p  q) = punit.lt p  lt q"
proof (rule lt_eqI_keys, simp only: in_keys_iff lookup_mult_scalar_lt_lt)
  from assms(1) have "punit.lc p  0" by (rule punit.lc_not_0)
  moreover from assms(2) have "lc q  0" by (rule lc_not_0)
  ultimately show "punit.lc p * lc q  0" by simp
qed (rule in_keys_mult_scalar_le)

lemma tt_mult_scalar:
  assumes "p  0" and "q  (0::'t 0 'b::semiring_no_zero_divisors)"
  shows "tt (p  q) = punit.tt p  tt q"
proof (rule tt_eqI, simp only: in_keys_iff lookup_mult_scalar_tt_tt)
  from assms(1) have "punit.tc p  0" by (rule punit.tc_not_0)
  moreover from assms(2) have "tc q  0" by (rule tc_not_0)
  ultimately show "punit.tc p * tc q  0" by simp
qed (rule in_keys_mult_scalar_ge)

lemma lc_mult_scalar: "lc (p  q) = punit.lc p * lc (q::'t 0 'b::semiring_no_zero_divisors)"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: lc_def)
next
  case False
  show ?thesis
  proof (cases "q = 0")
    case True
    thus ?thesis by (simp add: lc_def)
  next
    case False
    with p  0 show ?thesis by (simp add: lc_def lt_mult_scalar lookup_mult_scalar_lt_lt)
  qed
qed

lemma tc_mult_scalar: "tc (p  q) = punit.tc p * tc (q::'t 0 'b::semiring_no_zero_divisors)"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: tc_def)
next
  case False
  show ?thesis
  proof (cases "q = 0")
    case True
    thus ?thesis by (simp add: tc_def)
  next
    case False
    with p  0 show ?thesis by (simp add: tc_def tt_mult_scalar lookup_mult_scalar_tt_tt)
  qed
qed

lemma mult_scalar_not_zero:
  assumes "p  0" and "q  (0::'t 0 'b::semiring_no_zero_divisors)"
  shows "p  q  0"
proof
  assume "p  q = 0"
  hence "0 = lc (p  q)" by (simp add: lc_def)
  also have "... = punit.lc p * lc q" by (rule lc_mult_scalar)
  finally have "punit.lc p * lc q = 0" by simp
  moreover from assms(1) have "punit.lc p  0" by (rule punit.lc_not_0)
  moreover from assms(2) have "lc q  0" by (rule lc_not_0)
  ultimately show False by simp
qed

end (* ordered_term_powerprod *)

context ordered_powerprod
begin

lemmas in_keys_times_le = punit.in_keys_mult_scalar_le[simplified]
lemmas in_keys_times_ge = punit.in_keys_mult_scalar_ge[simplified]
lemmas lookup_times_lp_lp = punit.lookup_mult_scalar_lt_lt[simplified]
lemmas lookup_times_tp_tp = punit.lookup_mult_scalar_tt_tt[simplified]
lemmas lookup_times_monomial_right_plus = punit.lookup_mult_scalar_monomial_right_plus[simplified]
lemmas lookup_times_monomial_right = punit.lookup_mult_scalar_monomial_right[simplified]
lemmas lp_times = punit.lt_mult_scalar[simplified]
lemmas tp_times = punit.tt_mult_scalar[simplified]
lemmas lc_times = punit.lc_mult_scalar[simplified]
lemmas tc_times = punit.tc_mult_scalar[simplified]
lemmas times_not_zero = punit.mult_scalar_not_zero[simplified]
lemmas times_tail_rec_left = punit.mult_scalar_tail_rec_left[simplified]
lemmas times_tail_rec_right = punit.mult_scalar_tail_rec_right[simplified]
lemmas punit_in_keys_monom_mult_le = punit.in_keys_monom_mult_le[simplified]
lemmas punit_in_keys_monom_mult_ge = punit.in_keys_monom_mult_ge[simplified]
lemmas lp_monom_mult = punit.lt_monom_mult[simplified]
lemmas tp_monom_mult = punit.tt_monom_mult[simplified]

end

subsection @{term dgrad_p_set} and @{term dgrad_p_set_le}

locale gd_term =
    ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
      for pair_of_term::"'t  ('a::graded_dickson_powerprod × 'k::{the_min,wellorder})"
      and term_of_pair::"('a × 'k)  't"
      and ord::"'a  'a  bool" (infixl "" 50)
      and ord_strict (infixl "" 50)
      and ord_term::"'t  't  bool" (infixl "t" 50)
      and ord_term_strict::"'t  't  bool" (infixl "t" 50)
begin

sublocale gd_powerprod ..

lemma adds_term_antisym:
  assumes "u addst v" and "v addst u"
  shows "u = v"
  using assms unfolding adds_term_def using adds_antisym by (metis term_of_pair_pair)

definition dgrad_p_set :: "('a  nat)  nat  ('t 0 'b::zero) set"
  where "dgrad_p_set d m = {p. pp_of_term ` keys p  dgrad_set d m}"

definition dgrad_p_set_le :: "('a  nat)  (('t 0 'b) set)  (('t 0 'b::zero) set)  bool"
  where "dgrad_p_set_le d F G  (dgrad_set_le d (pp_of_term ` Keys F) (pp_of_term ` Keys G))"

lemma in_dgrad_p_set_iff: "p  dgrad_p_set d m  (vkeys p. d (pp_of_term v)  m)"
  by (auto simp add: dgrad_p_set_def dgrad_set_def)

lemma dgrad_p_setI [intro]:
  assumes "v. v  keys p  d (pp_of_term v)  m"
  shows "p  dgrad_p_set d m"
  using assms by (auto simp: in_dgrad_p_set_iff)

lemma dgrad_p_setD:
  assumes "p  dgrad_p_set d m" and "v  keys p"
  shows "d (pp_of_term v)  m"
  using assms by (simp only: in_dgrad_p_set_iff)

lemma zero_in_dgrad_p_set: "0  dgrad_p_set d m"
  by (rule, simp)

lemma dgrad_p_set_zero [simp]: "dgrad_p_set (λ_. 0) m = UNIV"
  by auto

lemma subset_dgrad_p_set_zero: "F  dgrad_p_set (λ_. 0) m"
  by simp

lemma dgrad_p_set_subset:
  assumes "m  n"
  shows "dgrad_p_set d m  dgrad_p_set d n"
  using assms by (auto simp: dgrad_p_set_def dgrad_set_def)

lemma dgrad_p_setD_lp:
  assumes "p  dgrad_p_set d m" and "p  0"
  shows "d (lp p)  m"
  by (rule dgrad_p_setD, fact, rule lt_in_keys, fact)

lemma dgrad_p_set_exhaust_expl:
  assumes "finite F"
  shows "F  dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
proof
  fix f
  assume "f  F"
  from assms have "finite (Keys F)" by (rule finite_Keys)
  have fin: "finite (d ` pp_of_term ` Keys F)" by (intro finite_imageI, fact)
  show "f  dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
  proof (rule dgrad_p_setI)
    fix v
    assume "v  keys f"
    from this f  F have "v  Keys F" by (rule in_KeysI)
    hence "d (pp_of_term v)  d ` pp_of_term ` Keys F" by simp
    with fin show "d (pp_of_term v)  Max (d ` pp_of_term ` Keys F)" by (rule Max_ge)
  qed
qed

lemma dgrad_p_set_exhaust:
  assumes "finite F"
  obtains m where "F  dgrad_p_set d m"
proof
  from assms show "F  dgrad_p_set d (Max (d ` pp_of_term ` Keys F))" by (rule dgrad_p_set_exhaust_expl)
qed

lemma dgrad_p_set_insert:
  assumes "F  dgrad_p_set d m"
  obtains n where "m  n" and "f  dgrad_p_set d n" and "F  dgrad_p_set d n"
proof -
  have "finite {f}" by simp
  then obtain m1 where "{f}  dgrad_p_set d m1" by (rule dgrad_p_set_exhaust)
  hence "f  dgrad_p_set d m1" by simp
  define n where "n = ord_class.max m m1"
  have "m  n" and "m1  n" by (simp_all add: n_def)
  from this(1) show ?thesis
  proof
    from m1  n have "dgrad_p_set d m1  dgrad_p_set d n" by (rule dgrad_p_set_subset)
    with f  dgrad_p_set d m1 show "f  dgrad_p_set d n" ..
  next
    from m  n have "dgrad_p_set d m  dgrad_p_set d n" by (rule dgrad_p_set_subset)
    with assms show "F  dgrad_p_set d n" by (rule subset_trans)
  qed
qed

lemma dgrad_p_set_leI:
  assumes "f. f  F  dgrad_p_set_le d {f} G"
  shows "dgrad_p_set_le d F G"
  unfolding dgrad_p_set_le_def dgrad_set_le_def
proof
  fix s
  assume "s  pp_of_term ` Keys F"
  then obtain v where "v  Keys F" and "s = pp_of_term v" ..
  from this(1) obtain f where "f  F" and "v  keys f" by (rule in_KeysE)
  from this(2) have "s  pp_of_term ` Keys {f}" by (simp add: s = pp_of_term v Keys_insert)
  from f  F have "dgrad_p_set_le d {f} G" by (rule assms)
  from this s  pp_of_term ` Keys {f} show "tpp_of_term ` Keys G. d s  d t"
    unfolding dgrad_p_set_le_def dgrad_set_le_def ..
qed

lemma dgrad_p_set_le_trans [trans]:
  assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d G H"
  shows "dgrad_p_set_le d F H"
  using assms unfolding dgrad_p_set_le_def by (rule dgrad_set_le_trans)

lemma dgrad_p_set_le_subset:
  assumes "F  G"
  shows "dgrad_p_set_le d F G"
  unfolding dgrad_p_set_le_def by (rule dgrad_set_le_subset, rule image_mono, rule Keys_mono, fact)

lemma dgrad_p_set_leI_insert_keys:
  assumes "dgrad_p_set_le d F G" and "dgrad_set_le d (pp_of_term ` keys f) (pp_of_term ` Keys G)"
  shows "dgrad_p_set_le d (insert f F) G"
  using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)

lemma dgrad_p_set_leI_insert:
  assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d {f} G"
  shows "dgrad_p_set_le d (insert f F) G"
  using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)

lemma dgrad_p_set_leI_Un:
  assumes "dgrad_p_set_le d F1 G" and "dgrad_p_set_le d F2 G"
  shows "dgrad_p_set_le d (F1  F2) G"
  using assms by (auto simp: dgrad_p_set_le_def dgrad_set_le_def Keys_Un)

lemma dgrad_p_set_le_dgrad_p_set:
  assumes "dgrad_p_set_le d F G" and "G  dgrad_p_set d m"
  shows "F  dgrad_p_set d m"
proof
  fix f
  assume "f  F"
  show "f  dgrad_p_set d m"
  proof (rule dgrad_p_setI)
    fix v
    assume "v  keys f"
    from this f  F have "v  Keys F" by (rule in_KeysI)
    hence "pp_of_term v  pp_of_term ` Keys F" by simp
    with assms(1) obtain s where "s  pp_of_term ` Keys G" and "d (pp_of_term v)  d s"
      unfolding dgrad_p_set_le_def by (rule dgrad_set_leE)
    from this(1) obtain u where "u  Keys G" and s: "s = pp_of_term u" ..
    from this(1) obtain g where "g  G" and "u  keys g" by (rule in_KeysE)
    from this(1) assms(2) have "g  dgrad_p_set d m" ..
    from this u  keys g have "d s  m" unfolding s by (rule dgrad_p_setD)
    with d (pp_of_term v)  d s show "d (pp_of_term v)  m" by (rule le_trans)
  qed
qed

lemma dgrad_p_set_le_except: "dgrad_p_set_le d {except p S} {p}"
  by (auto simp add: dgrad_p_set_le_def Keys_insert keys_except intro: dgrad_set_le_subset)

lemma dgrad_p_set_le_tail: "dgrad_p_set_le d {tail p} {p}"
  by (simp only: tail_def lower_def, fact dgrad_p_set_le_except)

lemma dgrad_p_set_le_plus: "dgrad_p_set_le d {p + q} {p, q}"
  by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact Poly_Mapping.keys_add)

lemma dgrad_p_set_le_uminus: "dgrad_p_set_le d {-p} {p}"
  by (simp add: dgrad_p_set_le_def Keys_insert keys_uminus, fact dgrad_set_le_refl)

lemma dgrad_p_set_le_minus: "dgrad_p_set_le d {p - q} {p, q}"
  by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact keys_minus)

lemma dgrad_set_le_monom_mult:
  assumes "dickson_grading d"
  shows "dgrad_set_le d (pp_of_term ` keys (monom_mult c t p)) (insert t (pp_of_term ` keys p))"
proof (rule dgrad_set_leI)
  fix s
  assume "s  pp_of_term ` keys (monom_mult c t p)"
  with keys_monom_mult_subset have "s  pp_of_term ` ((⊕) t ` keys p)" by fastforce
  then obtain v where "v  keys p" and s: "s = pp_of_term (t  v)" by fastforce
  have "d s = ord_class.max (d t) (d (pp_of_term v))"
    by (simp only: s pp_of_term_splus dickson_gradingD1[OF assms(1)])
  hence "d s = d t  d s = d (pp_of_term v)" by auto
  thus "tinsert t (pp_of_term ` keys p). d s  d t"
  proof
    assume "d s = d t"
    thus ?thesis by simp
  next
    assume "d s = d (pp_of_term v)"
    show ?thesis
    proof
      from d s = d (pp_of_term v) show "d s  d (pp_of_term v)" by simp
    next
      from v  keys p show "pp_of_term v  insert t (pp_of_term ` keys p)" by simp
    qed
  qed
qed

lemma dgrad_p_set_closed_plus:
  assumes "p  dgrad_p_set d m" and "q  dgrad_p_set d m"
  shows "p + q  dgrad_p_set d m"
proof -
  from dgrad_p_set_le_plus have "{p + q}  dgrad_p_set d m"
  proof (rule dgrad_p_set_le_dgrad_p_set)
    from assms show "{p, q}  dgrad_p_set d m" by simp
  qed
  thus ?thesis by simp
qed

lemma dgrad_p_set_closed_uminus:
  assumes "p  dgrad_p_set d m"
  shows "-p  dgrad_p_set d m"
proof -
  from dgrad_p_set_le_uminus have "{-p}  dgrad_p_set d m"
  proof (rule dgrad_p_set_le_dgrad_p_set)
    from assms show "{p}  dgrad_p_set d m" by simp
  qed
  thus ?thesis by simp
qed

lemma dgrad_p_set_closed_minus:
  assumes "p  dgrad_p_set d m" and "q  dgrad_p_set d m"
  shows "p - q  dgrad_p_set d m"
proof -
  from dgrad_p_set_le_minus have "{p - q}  dgrad_p_set d m"
  proof (rule dgrad_p_set_le_dgrad_p_set)
    from assms show "{p, q}  dgrad_p_set d m" by simp
  qed
  thus ?thesis by simp
qed

lemma dgrad_p_set_closed_monom_mult:
  assumes "dickson_grading d" and "d t  m" and "p  dgrad_p_set d m"
  shows "monom_mult c t p  dgrad_p_set d m"
proof (rule dgrad_p_setI)
  fix v
  assume "v  keys (monom_mult c t p)"
  hence "pp_of_term v  pp_of_term ` keys (monom_mult c t p)" by simp
  with dgrad_set_le_monom_mult[OF assms(1)] obtain s where "s  insert t (pp_of_term ` keys p)"
    and "d (pp_of_term v)  d s" by (rule dgrad_set_leE)
  from this(1) have "s = t  s  pp_of_term ` keys p" by simp
  thus "d (pp_of_term v)  m"
  proof
    assume "s = t"
    with d (pp_of_term v)  d s assms(2) show ?thesis by simp
  next
    assume "s  pp_of_term ` keys p"
    then obtain u where "u  keys p" and "s = pp_of_term u" ..
    from assms(3) this(1) have "d s  m" unfolding s = pp_of_term u by (rule dgrad_p_setD)
    with d (pp_of_term v)  d s show ?thesis by (rule le_trans)
  qed
qed

lemma dgrad_p_set_closed_monom_mult_zero:
  assumes "p  dgrad_p_set d m"
  shows "monom_mult c 0 p  dgrad_p_set d m"
proof (rule dgrad_p_setI)
  fix v
  assume "v  keys (monom_mult c 0 p)"
  hence "pp_of_term v  pp_of_term ` keys (monom_mult c 0 p)" by simp
  then obtain u where "u  keys (monom_mult c 0 p)" and eq: "pp_of_term v = pp_of_term u" ..
  from this(1) have "u  keys p" by (metis keys_monom_multE splus_zero)
  with assms have "d (pp_of_term u)  m" by (rule dgrad_p_setD)
  thus "d (pp_of_term v)  m" by (simp only: eq)
qed

lemma dgrad_p_set_closed_except:
  assumes "p  dgrad_p_set d m"
  shows "except p S  dgrad_p_set d m"
  by (rule dgrad_p_setI, rule dgrad_p_setD, rule assms, simp add: keys_except)

lemma dgrad_p_set_closed_tail:
  assumes "p  dgrad_p_set d m"
  shows "tail p  dgrad_p_set d m"
  unfolding tail_def lower_def using assms by (rule dgrad_p_set_closed_except)

subsection ‹Dickson's Lemma for Sequences of Terms›

lemma Dickson_term:
  assumes "dickson_grading d" and "finite K"
  shows "almost_full_on (addst) {t. pp_of_term t  dgrad_set d m  component_of_term t  K}"
    (is "almost_full_on _ ?A")
proof (rule almost_full_onI)
  fix seq :: "nat  't"
  assume *: "i. seq i  ?A"
  define seq' where "seq' = (λi. (pp_of_term (seq i), component_of_term (seq i)))"
  have "pp_of_term ` ?A  {x. d x  m}" by (auto dest: dgrad_setD)
  moreover from assms(1) have "almost_full_on (adds) {x. d x  m}" by (rule dickson_gradingD2)
  ultimately have "almost_full_on (adds) (pp_of_term ` ?A)" by (rule almost_full_on_subset)
  moreover have "almost_full_on (=) (component_of_term ` ?A)"
  proof (rule eq_almost_full_on_finite_set)
    have "component_of_term ` ?A  K" by blast
    thus "finite (component_of_term ` ?A)" using assms(2) by (rule finite_subset)
  qed
  ultimately have "almost_full_on (prod_le (adds) (=)) (pp_of_term ` ?A × component_of_term ` ?A)"
    by (rule almost_full_on_Sigma)
  moreover from * have "i. seq' i  pp_of_term ` ?A × component_of_term ` ?A" by (simp add: seq'_def)
  ultimately obtain i j where "i < j" and "prod_le (adds) (=) (seq' i) (seq' j)"
    by (rule almost_full_onD)
  from this(2) have "seq i addst seq j" by (simp add: seq'_def prod_le_def adds_term_def)
  with i < j show "good (addst) seq" by (rule goodI)
qed

corollary Dickson_termE:
  assumes "dickson_grading d" and "finite (component_of_term ` range (f::nat  't))"
    and "pp_of_term ` range f  dgrad_set d m"
  obtains i j where "i < j" and "f i addst f j"
proof -
  let ?A = "{t. pp_of_term t  dgrad_set d m  component_of_term t  component_of_term ` range f}"
  from assms(1, 2) have "almost_full_on (addst) ?A" by (rule Dickson_term)
  moreover from assms(3) have "i. f i  ?A" by blast
  ultimately obtain i j where "i < j" and "f i addst f j" by (rule almost_full_onD)
  thus ?thesis ..
qed

lemma ex_finite_adds_term:
  assumes "dickson_grading d" and "finite (component_of_term ` S)" and "pp_of_term ` S  dgrad_set d m"
  obtains T where "finite T" and "T  S" and "s. s  S  (tT. t addst s)"
proof -
  let ?A = "{t. pp_of_term t  dgrad_set d m  component_of_term t  component_of_term ` S}"
  have "reflp ((addst)::'t  _)" by (simp add: reflp_def adds_term_refl)
  moreover have "almost_full_on (addst) S"
  proof (rule almost_full_on_subset)
    from assms(3) show "S  ?A" by blast
  next
    from assms(1, 2) show "almost_full_on (addst) ?A" by (rule Dickson_term)
  qed
  ultimately obtain T where "finite T" and "T  S" and "s. s  S  (tT. t addst s)"
    by (rule almost_full_on_finite_subsetE, blast)
  thus ?thesis ..
qed

subsection ‹Well-foundedness›

definition dickson_less_v :: "('a  nat)  nat  't  't  bool"
  where "dickson_less_v d m v u  (d (pp_of_term v)  m  d (pp_of_term u)  m  v t u)"

definition dickson_less_p :: "('a  nat)  nat  ('t 0 'b)  ('t 0 'b::zero)  bool"
  where "dickson_less_p d m p q  ({p, q}  dgrad_p_set d m  p p q)"

lemma dickson_less_vI:
  assumes "d (pp_of_term v)  m" and "d (pp_of_term u)  m" and "v t u"
  shows "dickson_less_v d m v u"
  using assms by (simp add: dickson_less_v_def)

lemma dickson_less_vD1:
  assumes "dickson_less_v d m v u"
  shows "d (pp_of_term v)  m"
  using assms by (simp add: dickson_less_v_def)

lemma dickson_less_vD2:
  assumes "dickson_less_v d m v u"
  shows "d (pp_of_term u)  m"
  using assms by (simp add: dickson_less_v_def)

lemma dickson_less_vD3:
  assumes "dickson_less_v d m v u"
  shows "v t u"
  using assms by (simp add: dickson_less_v_def)

lemma dickson_less_v_irrefl: "¬ dickson_less_v d m v v"
  by (simp add: dickson_less_v_def)

lemma dickson_less_v_trans:
  assumes "dickson_less_v d m v u" and "dickson_less_v d m u w"
  shows "dickson_less_v d m v w"
  using assms by (auto simp add: dickson_less_v_def)

lemma wf_dickson_less_v_aux1:
  assumes "dickson_grading d" and "i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
  obtains i where "j. j > i  component_of_term (seq j) < component_of_term (seq i)"
proof -
  let ?Q = "pp_of_term ` range seq"
  have "pp_of_term (seq 0)  ?Q" by simp
  with wf_dickson_less[OF assms(1)] obtain t where "t  ?Q" and *: "s. dickson_less d m s t  s  ?Q"
    by (rule wfE_min[to_pred], blast)
  from this(1) obtain i where t: "t = pp_of_term (seq i)" by fastforce
  show ?thesis
  proof
    fix j
    assume "i < j"
    with _ assms(2) have dlv: "dickson_less_v d m (seq j) (seq i)"
    proof (rule transp_sequence)
      from dickson_less_v_trans show "transp (dickson_less_v d m)" by (rule transpI)
    qed
    hence "seq j t seq i" by (rule dickson_less_vD3)
    define s where "s = pp_of_term (seq j)"
    have "pp_of_term (seq j)  ?Q" by simp
    hence "¬ dickson_less d m s t" unfolding s_def using * by blast
    moreover from dlv have "d s  m" and "d t  m" unfolding s_def t
      by (rule dickson_less_vD1, rule dickson_less_vD2)
    ultimately have "t  s" by (simp add: dickson_less_def)
    show "component_of_term (seq j) < component_of_term (seq i)"
    proof (rule ccontr, simp only: not_less)
      assume "component_of_term (seq i)  component_of_term (seq j)"
      with t  s have "seq i t seq j" unfolding s_def t by (rule ord_termI)
      moreover from dlv have "seq j t seq i" by (rule dickson_less_vD3)
      ultimately show False by simp
    qed
  qed
qed

lemma wf_dickson_less_v_aux2:
  assumes "dickson_grading d" and "i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
    and "i::nat. component_of_term (seq i) < k"
  shows thesis
  using assms(2, 3)
proof (induct k arbitrary: seq thesis rule: less_induct)
  case (less k)
  from assms(1) less(2) obtain i where *: "j. j > i  component_of_term (seq j) < component_of_term (seq i)"
    by (rule wf_dickson_less_v_aux1, blast)
  define seq1 where "seq1 = (λj. seq (Suc (i + j)))"
  from less(3) show ?case
  proof (rule less(1))
    fix j
    show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact less(2))
  next
    fix j
    show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def *)
  qed
qed

lemma wf_dickson_less_v:
  assumes "dickson_grading d"
  shows "wfP (dickson_less_v d m)"
proof (rule wfP_chain, rule, elim exE)
  fix seq::"nat  't"
  assume "i. dickson_less_v d m (seq (Suc i)) (seq i)"
  hence *: "i. dickson_less_v d m (seq (Suc i)) (seq i)" ..
  with assms obtain i where **: "j. j > i  component_of_term (seq j) < component_of_term (seq i)"
    by (rule wf_dickson_less_v_aux1, blast)
  define seq1 where "seq1 = (λj. seq (Suc (i + j)))"
  from assms show False
  proof (rule wf_dickson_less_v_aux2)
    fix j
    show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact *)
  next
    fix j
    show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def **)
  qed
qed

lemma dickson_less_v_zero: "dickson_less_v (λ_. 0) m = (≺t)"
  by (rule, rule, simp add: dickson_less_v_def)

lemma dickson_less_pI:
  assumes "p  dgrad_p_set d m" and "q  dgrad_p_set d m" and "p p q"
  shows "dickson_less_p d m p q"
  using assms by (simp add: dickson_less_p_def)

lemma dickson_less_pD1:
  assumes "dickson_less_p d m p q"
  shows "p  dgrad_p_set d m"
  using assms by (simp add: dickson_less_p_def)

lemma dickson_less_pD2:
  assumes "dickson_less_p d m p q"
  shows "q  dgrad_p_set d m"
  using assms by (simp add: dickson_less_p_def)

lemma dickson_less_pD3:
  assumes "dickson_less_p d m p q"
  shows "p p q"
  using assms by (simp add: dickson_less_p_def)

lemma dickson_less_p_irrefl: "¬ dickson_less_p d m p p"
  by (simp add: dickson_less_p_def)

lemma dickson_less_p_trans:
  assumes "dickson_less_p d m p q" and "dickson_less_p d m q r"
  shows "dickson_less_p d m p r"
  using assms by (auto simp add: dickson_less_p_def)

lemma dickson_less_p_mono:
  assumes "dickson_less_p d m p q" and "m  n"
  shows "dickson_less_p d n p q"
proof -
  from assms(2) have "dgrad_p_set d m  dgrad_p_set d n" by (rule dgrad_p_set_subset)
  moreover from assms(1) have "p  dgrad_p_set d m" and "q  dgrad_p_set d m" and "p p q"
    by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
  ultimately have "p  dgrad_p_set d n" and "q  dgrad_p_set d n" by auto
  from this p p q show ?thesis by (rule dickson_less_pI)
qed

lemma dickson_less_p_zero: "dickson_less_p (λ_. 0) m = (≺p)"
  by (rule, rule, simp add: dickson_less_p_def)

lemma wf_dickson_less_p_aux:
  assumes "dickson_grading d"
  assumes "x  Q" and "yQ. y  0  (y  dgrad_p_set d m  dickson_less_v d m (lt y) u)"
  shows "pQ. (qQ. ¬ dickson_less_p d m q p)"
  using assms(2) assms(3)
proof (induct u arbitrary: x Q rule: wfP_induct[OF wf_dickson_less_v, OF assms(1)])
  fix u::'t and x::"'t 0 'b" and Q::"('t 0 'b) set"
  assume hyp: "u0. dickson_less_v d m u0 u  (x0 Q0::('t 0 'b) set. x0  Q0 
                            (yQ0. y  0  (y  dgrad_p_set d m  dickson_less_v d m (lt y) u0)) 
                            (pQ0. qQ0. ¬ dickson_less_p d m q p))"
  assume "x  Q"
  assume "yQ. y  0  (y  dgrad_p_set d m  dickson_less_v d m (lt y) u)"
  hence bounded: "y. y  Q  y  0  (y  dgrad_p_set d m  dickson_less_v d m (lt y) u)" by auto
  show "pQ. qQ. ¬ dickson_less_p d m q p"
  proof (cases "0  Q")
    case True
    show ?thesis
    proof (rule, rule, rule)
      fix q::"'t 0 'b"
      assume "dickson_less_p d m q 0"
      hence "q p 0" by (rule dickson_less_pD3)
      thus False using ord_p_zero_min[of q] by simp
    next
      from True show "0  Q" .
    qed
  next
    case False
    define Q1 where "Q1 = {lt p | p. p  Q}"
    from x  Q have "lt x  Q1" unfolding Q1_def by auto
    with wf_dickson_less_v[OF assms(1)] obtain v
      where "v  Q1" and v_min_1: "q. dickson_less_v d m q v  q  Q1"
      by (rule wfE_min[to_pred], auto)
    have v_min: "q. q  Q  ¬ dickson_less_v d m (lt q) v"
    proof -
      fix q
      assume "q  Q"
      hence "lt q  Q1" unfolding Q1_def by auto
      thus "¬ dickson_less_v d m (lt q) v" using v_min_1 by auto
    qed
    from v  Q1 obtain p where "lt p = v" and "p  Q" unfolding Q1_def by auto
    hence "p  0" using False by auto
    with p  Q have "p  dgrad_p_set d m  dickson_less_v d m (lt p) u" by (rule bounded)
    hence "p  dgrad_p_set d m" and "dickson_less_v d m (lt p) u" by simp_all
    moreover from this(1) p  0 have "d (pp_of_term (lt p))  m" by (rule dgrad_p_setD_lp)
    ultimately have "d (pp_of_term v)  m" by (simp only: ‹lt p = v)
    define Q2 where "Q2 = {tail p | p. p  Q  lt p = v}"
    from p  Q ‹lt p = v have "tail p  Q2" unfolding Q2_def by auto
    have "qQ2. q  0  (q  dgrad_p_set d m  dickson_less_v d m (lt q) (lt p))"
    proof (intro ballI impI)
      fix q
      assume "q  Q2"
      then obtain q0 where q: "q = tail q0" and "lt q0 = lt p" and "q0  Q"
        using ‹lt p = v by (auto simp add: Q2_def)
      assume "q  0"
      hence "tail q0  0" using q = tail q0 by simp
      hence "q0  0" by auto
      with q0  Q have "q0  dgrad_p_set d m  dickson_less_v d m (lt q0) u" by (rule bounded)
      hence "q0  dgrad_p_set d m" and "dickson_less_v d m (lt q0) u" by simp_all
      from this(1) have "q  dgrad_p_set d m" unfolding q by (rule dgrad_p_set_closed_tail)
      show "q  dgrad_p_set d m  dickson_less_v d m (lt q) (lt p)"
      proof
        show "dickson_less_v d m (lt q) (lt p)"
        proof (rule dickson_less_vI)
          from q  dgrad_p_set d m q  0 show "d (pp_of_term (lt q))  m" by (rule dgrad_p_setD_lp)
        next
          from ‹dickson_less_v d m (lt p) u show "d (pp_of_term (lt p))  m" by (rule dickson_less_vD1)
        next
          from lt_tail[OF ‹tail q0  0] q = tail q0 ‹lt q0 = lt p show "lt q t lt p" by simp
        qed
      qed fact
    qed
    with hyp ‹dickson_less_v d m (lt p) u ‹tail p  Q2 have "pQ2. qQ2. ¬ dickson_less_p d m q p"
      by blast
    then obtain q where "q  Q2" and q_min: "rQ2. ¬ dickson_less_p d m r q" ..
    from q  Q2 obtain q0 where "q = tail q0" and "q0  Q" and "lt q0 = v" unfolding Q2_def by auto
    from q_min q = tail q0 have q0_tail_min: "r. r  Q2  ¬ dickson_less_p d m r (tail q0)" by simp
    from q0  Q show ?thesis
    proof
      show "rQ. ¬ dickson_less_p d m r q0"
      proof (intro ballI notI)
        fix r
        assume "dickson_less_p d m r q0"
        hence "r  dgrad_p_set d m" and "q0  dgrad_p_set d m" and "r p q0"
          by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
        from this(3) have "lt r t lt q0" by (simp add: ord_p_lt)
        with ‹lt q0 = v have "lt r t v" by simp
        assume "r  Q"
        hence "¬ dickson_less_v d m (lt r) v" by (rule v_min)
        from False r  Q have "r  0" using False by blast
        with r  dgrad_p_set d m have "d (pp_of_term (lt r))  m" by (rule dgrad_p_setD_lp)
        have "¬ lt r t v"
        proof
          assume "lt r t v"
          with d (pp_of_term (lt r))  m d (pp_of_term v)  m have "dickson_less_v d m (lt r) v"
            by (rule dickson_less_vI)
          with ¬ dickson_less_v d m (lt r) v show False ..
        qed
        with ‹lt r t v have "lt r = v" by simp
        with r  Q have "tail r  Q2" by (auto simp add: Q2_def)
        have "dickson_less_p d m (tail r) (tail q0)"
        proof (rule dickson_less_pI)
          show "tail r  dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
        next
          show "tail q0  dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
        next
          have "lt r = lt q0" by (simp only: ‹lt r = v ‹lt q0 = v)
          from r  0 this r p q0 show "tail r p tail q0" by (rule ord_p_tail)
        qed
        with q0_tail_min[OF ‹tail r  Q2] show False ..
      qed
    qed
  qed
qed

theorem wf_dickson_less_p:
  assumes "dickson_grading d"
  shows "wfP (dickson_less_p d m)"
proof (rule wfI_min[to_pred])
  fix Q::"('t 0 'b) set" and x
  assume "x  Q"
  show "zQ. y. dickson_less_p d m y z  y  Q"
  proof (cases "0  Q")
    case True
    show ?thesis
    proof (rule, rule, rule)
      from True show "0  Q" .
    next
      fix q::"'t 0 'b"
      assume "dickson_less_p d m q 0"
      hence "q p 0" by (rule dickson_less_pD3)
      thus "q  Q" using ord_p_zero_min[of q] by simp
    qed
  next
    case False
    show ?thesis
    proof (cases "Q  dgrad_p_set d m")
      case True
      let ?L = "lt ` Q"
      from x  Q have "lt x  ?L" by simp
      with wf_dickson_less_v[OF assms] obtain v where "v  ?L"
        and v_min: "u. dickson_less_v d m u v  u  ?L" by (rule wfE_min[to_pred], blast)
      from this(1) obtain x1 where "x1  Q" and "v = lt x1" ..
      from this(1) True False have "x1  dgrad_p_set d m" and "x1  0" by auto
      hence "d (pp_of_term v)  m" unfolding v = lt x1 by (rule dgrad_p_setD_lp)
      define Q1 where "Q1 = {tail p | p. p  Q  lt p = v}"
      from x1  Q have "tail x1  Q1" by (auto simp add: Q1_def v = lt x1)
      with assms have "pQ1. qQ1. ¬ dickson_less_p d m q p"
      proof (rule wf_dickson_less_p_aux)
        show "yQ1. y  0  y  dgrad_p_set d m  dickson_less_v d m (lt y) v"
        proof (intro ballI impI)
          fix y
          assume "y  Q1" and "y  0"
          from this(1) obtain y1 where "y1  Q" and "v = lt y1" and "y = tail y1" unfolding Q1_def
            by blast
          from this(1) True have "y1  dgrad_p_set d m" ..
          hence "y  dgrad_p_set d m" unfolding y = tail y1 by (rule dgrad_p_set_closed_tail)
          thus "y  dgrad_p_set d m  dickson_less_v d m (lt y) v"
          proof
            show "dickson_less_v d m (lt y) v"
            proof (rule dickson_less_vI)
              from y  dgrad_p_set d m y  0 show "d (pp_of_term (lt y))  m"
                by (rule dgrad_p_setD_lp)
            next
              from y  0 show "lt y t v" unfolding v = lt y1 y = tail y1 by (rule lt_tail)
            qed fact
          qed
        qed
      qed
      then obtain p0 where "p0  Q1" and p0_min: "q. q  Q1  ¬ dickson_less_p d m q p0" by blast
      from this(1) obtain p where "p  Q" and "v = lt p" and "p0 = tail p" unfolding Q1_def
        by blast
      from this(1) False have "p  0" by blast
      show ?thesis
      proof (intro bexI allI impI notI)
        fix y
        assume "y  Q"
        hence "y  0" using False by blast
        assume "dickson_less_p d m y p"
        hence "y  dgrad_p_set d m" and "p  dgrad_p_set d m" and "y p p"
          by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
        from this(3) have "y p p" by simp
        hence "lt y t lt p" by (rule ord_p_lt)
        moreover have "¬ lt y t lt p"
        proof
          assume "lt y t lt p"
          have "dickson_less_v d m (lt y) v" unfolding v = lt p
            by (rule dickson_less_vI, rule dgrad_p_setD_lp, fact+, rule dgrad_p_setD_lp, fact+)
          hence "lt y  ?L" by (rule v_min)
          hence "y  Q" by fastforce
          from this y  Q show False ..
        qed
        ultimately have "lt y = lt p" by simp
        from y  0 this y p p have "tail y p tail p" by (rule ord_p_tail)
        from y  Q have "tail y  Q1" by (auto simp add: Q1_def v = lt p ‹lt y = lt p[symmetric])
        hence "¬ dickson_less_p d m (tail y) p0" by (rule p0_min)
        moreover have "dickson_less_p d m (tail y) p0" unfolding p0 = tail p
          by (rule dickson_less_pI, rule dgrad_p_set_closed_tail, fact, rule dgrad_p_set_closed_tail, fact+)
        ultimately show False ..
      qed fact
    next
      case False
      then obtain q where "q  Q" and "q  dgrad_p_set d m" by blast
      from this(1) show ?thesis
      proof
        show "y. dickson_less_p d m y q  y  Q"
        proof (intro allI impI)
          fix y
          assume "dickson_less_p d m y q"
          hence "q  dgrad_p_set d m" by (rule dickson_less_pD2)
          with q  dgrad_p_set d m show "y  Q" ..
        qed
      qed
    qed
  qed
qed

corollary ord_p_minimum_dgrad_p_set:
  assumes "dickson_grading d" and "x  Q" and "Q  dgrad_p_set d m"
  obtains q where "q  Q" and "y. y p q  y  Q"
proof -
  from assms(1) have "wfP (dickson_less_p d m)" by (rule wf_dickson_less_p)
  from this assms(2) obtain q where "q  Q" and *: "y. dickson_less_p d m y q  y  Q"
    by (rule wfE_min[to_pred], auto)
  from assms(3) q  Q have "q  dgrad_p_set d m" ..
  from q  Q show ?thesis
  proof
    fix y
    assume "y p q"
    show "y  Q"
    proof
      assume "y  Q"
      with assms(3) have "y  dgrad_p_set d m" ..
      from this q  dgrad_p_set d m y p q have "dickson_less_p d m y q"
        by (rule dickson_less_pI)
      hence "y  Q" by (rule *)
      from this y  Q show False ..
    qed
  qed
qed

lemma ord_term_minimum_dgrad_set:
  assumes "dickson_grading d" and "v  V" and "pp_of_term ` V  dgrad_set d m"
  obtains u where "u  V" and "w. w t u  w  V"
proof -
  from assms(1) have "wfP (dickson_less_v d m)" by (rule wf_dickson_less_v)
  then obtain u where "u  V" and *: "w. dickson_less_v d m w u  w  V" using assms(2)
    by (rule wfE_min[to_pred]) blast
  from this(1) have "pp_of_term u  pp_of_term ` V" by (rule imageI)
  with assms(3) have "pp_of_term u  dgrad_set d m" ..
  hence "d (pp_of_term u)  m" by (rule dgrad_setD)
  from u  V show ?thesis
  proof
    fix w
    assume "w t u"
    show "w  V"
    proof
      assume "w  V"
      hence "pp_of_term w  pp_of_term ` V" by (rule imageI)
      with assms(3) have "pp_of_term w  dgrad_set d m" ..
      hence "d (pp_of_term w)  m" by (rule dgrad_setD)
      from this d (pp_of_term u)  m w t u have "dickson_less_v d m w u"
        by (rule dickson_less_vI)
      hence "w  V" by (rule *)
      from this w  V show False ..
    qed
  qed
qed

end (* gd_term *)

subsection ‹More Interpretations›

context gd_powerprod
begin

sublocale punit: gd_term to_pair_unit fst "(≼)" "(≺)" "(≼)" "(≺)" ..

end

locale od_term =
    ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
      for pair_of_term::"'t  ('a::dickson_powerprod × 'k::{the_min,wellorder})"
      and term_of_pair::"('a × 'k)  't"
      and ord::"'a  'a  bool" (infixl "" 50)
      and ord_strict (infixl "" 50)
      and ord_term::"'t  't  bool" (infixl "t" 50)
      and ord_term_strict::"'t  't  bool" (infixl "t" 50)
begin

sublocale gd_term ..

lemma ord_p_wf: "wfP (≺p)"
proof -
  from dickson_grading_zero have "wfP (dickson_less_p (λ_. 0) 0)" by (rule wf_dickson_less_p)
  thus ?thesis by (simp only: dickson_less_p_zero)
qed

end (* od_term *)

end (* theory *)

Theory Poly_Mapping_Finite_Map

(* Author: Fabian Immler, TU Muenchen
*)
theory Poly_Mapping_Finite_Map
  imports
    "More_MPoly_Type"
    "HOL-Library.Finite_Map"
begin

subsection ‹TODO: move!›

lemma fmdom'_fmap_of_list: "fmdom' (fmap_of_list xs) = set (map fst xs)"
  by (auto simp: fmdom'_def fmdom'I fmap_of_list.rep_eq weak_map_of_SomeI)
    (metis map_of_eq_None_iff option.distinct(1))


text ‹In this theory, type @{typ "('a, 'b) poly_mapping"} is represented as association lists.
  Code equations are proved in order actually perform computations (addition, multiplication, etc.).›

subsection ‹Utilities›

instantiation poly_mapping :: (type, "{equal, zero}") equal
begin
definition equal_poly_mapping::"('a, 'b) poly_mapping  ('a, 'b) poly_mapping  bool" where
  "equal_poly_mapping p q  (t. lookup p t = lookup q t)"

instance by standard (auto simp add: equal_poly_mapping_def poly_mapping_eqI)
end

definition "clearjunk0 m = fmfilter (λk. fmlookup m k  Some 0) m"

definition "fmlookup_default d m x = (case fmlookup m x of Some v  v | None  d)"
abbreviation "lookup0  fmlookup_default 0"

lemma fmlookup_default_fmmap:
  "fmlookup_default d (fmmap f M) x = (if x  fmdom' M then f (fmlookup_default d M x) else d)"
  by (auto simp: fmlookup_default_def fmdom'_notI split: option.splits)

lemma fmlookup_default_fmmap_keys: "fmlookup_default d (fmmap_keys f M) x =
  (if x  fmdom' M then f x (fmlookup_default d M x) else d)"
  by (auto simp: fmlookup_default_def fmdom'_notI split: option.splits)

lemma fmlookup_default_add[simp]:
  "fmlookup_default d (m ++f n) x =
    (if x |∈| fmdom n then the (fmlookup n x)
    else fmlookup_default d m x)"
  by (auto simp: fmlookup_default_def)

lemma fmlookup_default_if[simp]:
  "fmlookup ys a = Some r  fmlookup_default d ys a = r"
  "fmlookup ys a = None  fmlookup_default d ys a = d"
  by (auto simp: fmlookup_default_def)

lemma finite_lookup_default:
  "finite {x. fmlookup_default d xs x  d}"
proof -
  have "{x. fmlookup_default d xs x  d}  fmdom' xs"
    by (auto simp: fmlookup_default_def fmdom'I split: option.splits)
  also have "finite "
    by simp
  finally (finite_subset) show ?thesis .
qed

lemma lookup0_clearjunk0: "lookup0 xs s = lookup0 (clearjunk0 xs) s"
  unfolding clearjunk0_def fmlookup_default_def
  by auto

lemma clearjunk0_nonzero:
  assumes "t  fmdom' (clearjunk0 xs)"
  shows "fmlookup xs t  Some 0"
  using assms unfolding clearjunk0_def by simp

lemma clearjunk0_map_of_SomeD:
  assumes a1: "fmlookup xs t = Some c" and "c  0"
  shows "t  fmdom' (clearjunk0 xs)"
  using assms
  by (auto simp: clearjunk0_def fmdom'I)


subsection ‹Implementation of Polynomial Mappings as Association Lists›

lift_definition Pm_fmap::"('a, 'b::zero) fmap  'a 0 'b" is lookup0
  by (rule finite_lookup_default)

lemmas [simp] = Pm_fmap.rep_eq

code_datatype Pm_fmap

lemma PM_clearjunk0_cong:
  "Pm_fmap (clearjunk0 xs) = Pm_fmap xs"
  by (metis Pm_fmap.rep_eq lookup0_clearjunk0 poly_mapping_eqI)

lemma PM_all_2:
  assumes "P 0 0"
  shows "(x. P (lookup (Pm_fmap xs) x) (lookup (Pm_fmap ys) x)) =
    fmpred (λk v. P (lookup0 xs k) (lookup0 ys k)) (xs ++f ys)"
  using assms unfolding list_all_def
  by (force simp: fmlookup_default_def fmlookup_dom_iff
      split: option.splits if_splits)

lemma compute_keys_pp[code]: "keys (Pm_fmap xs) = fmdom' (clearjunk0 xs)"
  by transfer
    (auto simp: fmlookup_dom'_iff clearjunk0_def fmlookup_default_def fmdom'I split: option.splits)

lemma compute_zero_pp[code]: "0 = Pm_fmap fmempty"
  by (auto intro!: poly_mapping_eqI simp: fmlookup_default_def)

lemma compute_plus_pp [code]:
  "Pm_fmap xs + Pm_fmap ys = Pm_fmap (clearjunk0 (fmmap_keys (λk v. lookup0 xs k + lookup0 ys k) (xs ++f ys)))"
  by (auto intro!: poly_mapping_eqI
      simp: fmlookup_default_def lookup_add fmlookup_dom_iff PM_clearjunk0_cong
      split: option.splits)

lemma compute_lookup_pp[code]:
  "lookup (Pm_fmap xs) x = lookup0 xs x"
  by (transfer, simp)

lemma compute_minus_pp [code]:
  "Pm_fmap xs - Pm_fmap ys = Pm_fmap (clearjunk0 (fmmap_keys (λk v. lookup0 xs k - lookup0 ys k) (xs ++f ys)))"
  by (auto intro!: poly_mapping_eqI
      simp: fmlookup_default_def lookup_minus fmlookup_dom_iff PM_clearjunk0_cong
      split: option.splits)

lemma compute_uminus_pp[code]:
  "- Pm_fmap ys = Pm_fmap (fmmap_keys (λk v. - lookup0 ys k) ys)"
  by (auto intro!: poly_mapping_eqI
      simp: fmlookup_default_def
      split: option.splits)

lemma compute_equal_pp[code]:
  "equal_class.equal (Pm_fmap xs) (Pm_fmap ys) = fmpred (λk v. lookup0 xs k = lookup0 ys k) (xs ++f ys)"
  unfolding equal_poly_mapping_def by (simp only: PM_all_2)

lemma compute_map_pp[code]:
  "Poly_Mapping.map f (Pm_fmap xs) = Pm_fmap (fmmap (λx. f x when x  0) xs)"
  by (auto intro!: poly_mapping_eqI
      simp: fmlookup_default_def map.rep_eq
      split: option.splits)

lemma fmran'_fmfilter_eq: "fmran' (fmfilter p fm) = {y | y. x  fmdom' fm. p x  fmlookup fm x = Some y}"
  by (force simp: fmlookup_ran'_iff fmdom'I split: if_splits)

lemma compute_range_pp[code]:
  "Poly_Mapping.range (Pm_fmap xs) = fmran' (clearjunk0 xs)"
  by (force simp: range.rep_eq clearjunk0_def fmran'_fmfilter_eq fmdom'I
      fmlookup_default_def split: option.splits)

subsubsection ‹Constructors›

definition "sparse0 xs = Pm_fmap (fmap_of_list xs)" ―‹sparse representation›
definition "dense0 xs = Pm_fmap (fmap_of_list (zip [0..<length xs] xs))" ―‹dense representation›

lemma compute_single[code]: "Poly_Mapping.single k v = sparse0 [(k, v)]"
  by (auto simp: sparse0_def fmlookup_default_def lookup_single intro!: poly_mapping_eqI )

end

Theory MPoly_Type_Class_FMap

(* Author: Fabian Immler, Alexander Maletzky *)

section ‹Executable Representation of Polynomial Mappings as Association Lists›

theory MPoly_Type_Class_FMap
  imports
    MPoly_Type_Class_Ordered
    Poly_Mapping_Finite_Map
begin

text ‹In this theory, (type class) multivariate polynomials of type
  @{typ "('a, 'b) poly_mapping"} are represented as association lists.›

text ‹It is important to note that theory MPoly_Type_Class_OAlist›, which represents polynomials as
  @{emph ‹ordered›} associative lists, is much better suited for doing actual computations. This
  theory is only included for being able to compare the two representations in terms of efficiency.›

subsection ‹Power Products›

lemma compute_lcs_pp[code]:
  "lcs (Pm_fmap xs) (Pm_fmap ys) =
  Pm_fmap (fmmap_keys (λk v. Orderings.max (lookup0 xs k) (lookup0 ys k)) (xs ++f ys))"
  by (rule poly_mapping_eqI)
    (auto simp add: fmlookup_default_fmmap_keys fmlookup_dom_iff fmdom'_notI
      lcs_poly_mapping.rep_eq fmdom'_notD)

lemma compute_deg_pp[code]:
  "deg_pm (Pm_fmap xs) = sum (the o fmlookup xs) (fmdom' xs)"
proof -
  have "deg_pm (Pm_fmap xs) = sum (lookup (Pm_fmap xs)) (keys (Pm_fmap xs))"
    by (rule deg_pm_superset) auto
  also have " = sum (the o fmlookup xs) (fmdom' xs)"
    by (rule sum.mono_neutral_cong_left)
       (auto simp: fmlookup_dom'_iff fmdom'I in_keys_iff fmlookup_default_def
             split: option.splits)
  finally show ?thesis .
qed

definition adds_pp_add_linorder :: "('b 0 'a::add_linorder)  _  bool"
  where [code_abbrev]: "adds_pp_add_linorder = (adds)"

lemma compute_adds_pp[code]:
  "adds_pp_add_linorder (Pm_fmap xs) (Pm_fmap ys) =
    (fmpred (λk v. lookup0 xs k  lookup0 ys k) (xs ++f ys))"
  for xs ys::"('a, 'b::add_linorder_min) fmap"
  unfolding adds_pp_add_linorder_def
  unfolding adds_poly_mapping
  using fmdom_notI
  by (force simp: fmlookup_dom_iff le_fun_def
      split: option.splits if_splits)


text‹Computing @{term lex} as below is certainly not the most efficient way, but it works.›

lemma lex_pm_iff: "lex_pm s t = (x. lookup s x  lookup t x  (y<x. lookup s y  lookup t y))"
proof -
  have "lex_pm s t = (¬ lex_pm_strict t s)" by (simp add: lex_pm_strict_alt)
  also have " = (x. lookup s x  lookup t x  (y<x. lookup s y  lookup t y))"
    by (simp add: lex_pm_strict_def less_poly_mapping_def less_fun_def) (metis leD leI)
  finally show ?thesis .
qed

lemma compute_lex_pp[code]:
  "(lex_pm (Pm_fmap xs) (Pm_fmap (ys::(_, _::ordered_comm_monoid_add) fmap))) =
    (let zs = xs ++f ys in
      fmpred (λx v.
        lookup0 xs x  lookup0 ys x 
        ¬ fmpred (λy w. y  x  lookup0 xs y = lookup0 ys y) zs) zs
    )"
  unfolding Let_def lex_pm_iff fmpred_iff Pm_fmap.rep_eq fmlookup_add fmlookup_dom_iff
  apply (intro iffI)
   apply (metis fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff leD)
  apply (metis eq_iff not_le fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff)
  done

lemma compute_dord_pp[code]:
  "(dord_pm ord (Pm_fmap xs) (Pm_fmap (ys::('a::wellorder , 'b::ordered_comm_monoid_add) fmap))) =
    (let dx = deg_pm (Pm_fmap xs) in let dy = deg_pm (Pm_fmap ys) in
      dx < dy  (dx = dy  ord (Pm_fmap xs) (Pm_fmap ys))
    )"
  by (auto simp: Let_def deg_pm.rep_eq dord_fun_def dord_pm.rep_eq)
    (simp_all add: Pm_fmap.abs_eq)


subsubsection ‹Computations›

experiment begin

abbreviation "X  0::nat"
abbreviation "Y  1::nat"
abbreviation "Z  2::nat"

lemma
  "sparse0 [(X, 2::nat), (Z, 7)] + sparse0 [(Y, 3), (Z, 2)] = sparse0 [(X, 2), (Z, 9), (Y, 3)]"
  "dense0 [2, 0, 7::nat] + dense0 [0, 3, 2] = dense0 [2, 3, 9]"
  by eval+

lemma
  "sparse0 [(X, 2::nat), (Z, 7)] - sparse0 [(X, 2), (Z, 2)] = sparse0 [(Z, 5)]"
  by eval

lemma
  "lcs (sparse0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse0 [(Y, 3), (Z, 2)]) = sparse0 [(X, 2), (Y, 3), (Z, 7)]"
  by eval

lemma
  "(sparse0 [(X, 2::nat), (Z, 1)]) adds (sparse0 [(X, 3), (Y, 2), (Z, 1)])"
  by eval

lemma
  "lookup (sparse0 [(X, 2::nat), (Z, 3)]) X = 2"
  by eval

lemma
  "deg_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
  by eval

lemma
  "lex_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)])"
by eval

lemma
  "lex_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)])"
  by eval

lemma
  "¬ (dlex_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)]))"
  by eval

lemma
  "dlex_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse0 [(X, 5)])"
  by eval

lemma
  "¬ (drlex_pm (sparse0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse0 [(X, 5)]))"
  by eval

end


subsection ‹Implementation of Multivariate Polynomials as Association Lists›

subsubsection ‹Unordered Power-Products›

lemma compute_monomial [code]:
  "monomial c t = (if c = 0 then 0 else sparse0 [(t, c)])"
  by (auto intro!: poly_mapping_eqI simp: sparse0_def fmlookup_default_def lookup_single)

lemma compute_one_poly_mapping [code]: "1 = sparse0 [(0, 1)]"
  by (metis compute_monomial single_one zero_neq_one)

lemma compute_except_poly_mapping [code]:
  "except (Pm_fmap xs) S = Pm_fmap (fmfilter (λk. k  S) xs)"
  by (auto simp: fmlookup_default_def lookup_except split: option.splits intro!: poly_mapping_eqI)

lemma lookup0_fmap_of_list_simps:
  "lookup0 (fmap_of_list ((x, y)#xs)) i = (if x = i then y else lookup0 (fmap_of_list xs) i)"
  "lookup0 (fmap_of_list []) i = 0"
  by (auto simp: fmlookup_default_def fmlookup_of_list split: if_splits option.splits)

lemma if_poly_mapping_eq_iff:
  "(if x = y then a else b) =
    (if (ikeys x  keys y. lookup x i = lookup y i) then a else b)"
  by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)

lemma keys_add_eq: "keys (a + b) = keys a  keys b - {x  keys a  keys b. lookup a x + lookup b x = 0}"
  by (auto simp: in_keys_iff lookup_add add_eq_0_iff)

context term_powerprod
begin

context includes fmap.lifting begin

lift_definition shift_keys::"'a  ('t, 'b) fmap  ('t, 'b) fmap"
  is "λt m x. if t addsp x then m (x  t) else None"
proof -
  fix t and f::"'t  'b option"
  assume "finite (dom f)"
  have "dom (λx. if t addsp x then f (x  t) else None)  (⊕) t ` dom f"
    by (auto simp: adds_pp_alt domI term_simps split: if_splits)
  also have "finite "
    using ‹finite (dom f) by simp
  finally (finite_subset) show "finite (dom (λx. if t addsp x then f (x  t) else None))" .
qed

definition "shift_map_keys t f m = fmmap f (shift_keys t m)"

lemma compute_shift_map_keys[code]:
  "shift_map_keys t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (t  k, f v)) xs)"
  unfolding shift_map_keys_def
  apply transfer
  subgoal for f t xs
  proof -
    show ?thesis
      apply (rule ext)
      subgoal for x
        apply (cases "t addsp x")
        subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
        subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
        done
      done
  qed
  done

end

lemmas [simp] = compute_zero_pp[symmetric]

lemma compute_monom_mult_poly_mapping [code]:
  "monom_mult c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
  case True
  hence "monom_mult c t (Pm_fmap xs) = 0" using monom_mult_zero_left by simp
  thus ?thesis using True
    by simp
next
  case False
  thus ?thesis
    by (auto simp: simp: fmlookup_default_def shift_map_keys_def lookup_monom_mult
        adds_def group_eq_aux shift_keys.rep_eq
        intro!: poly_mapping_eqI split: option.splits)
qed

lemma compute_mult_scalar_poly_mapping [code]:
  "Pm_fmap (fmap_of_list xs)  q = (case xs of ((t, c) # ys) 
    (monom_mult c t q + except (Pm_fmap (fmap_of_list ys)) {t}  q) | _ 
    Pm_fmap fmempty)"
proof (split list.splits, simp, intro conjI impI allI, goal_cases)
  case (1 t c ys)
  have "Pm_fmap (fmupd t c (fmap_of_list ys)) = sparse0 [(t, c)] + except (sparse0 ys) {t}"
    by (auto simp: sparse0_def fmlookup_default_def lookup_add lookup_except
        split: option.splits intro!: poly_mapping_eqI)
  also have "sparse0 [(t, c)] = monomial c t"
    by (auto simp: sparse0_def lookup_single fmlookup_default_def intro!: poly_mapping_eqI)
  finally show ?case
    by (simp add: algebra_simps mult_scalar_monomial sparse0_def)
qed

end (* term_powerprod *)

subsubsection ‹restore constructor view›

named_theorems mpoly_simps

definition "monomial1 pp = monomial 1 pp"

lemma monomial1_Nil[mpoly_simps]: "monomial1 0 = 1"
  by (simp add: monomial1_def)

lemma monomial_mp: "monomial c (pp::'a0nat) = Const0 c * monomial1 pp"
  for c::"'b::comm_semiring_1"
  by (auto intro!: poly_mapping_eqI simp: monomial1_def Const0_def mult_single)

lemma monomial1_add: "(monomial1 (a + b)::('a::monoid_add0'b::comm_semiring_1)) = monomial1 a * monomial1 b"
  by (auto simp: monomial1_def mult_single)

lemma monomial1_monomial: "monomial1 (monomial n v) = (Var0 v::_0('b::comm_semiring_1))^n"
  by (auto intro!: poly_mapping_eqI simp: monomial1_def Var0_power lookup_single when_def)

lemma Ball_True: "(xX. True)  True" by auto
lemma Collect_False: "{x. False} = {}" by simp

lemma Pm_fmap_sum: "Pm_fmap f = (x  fmdom' f. monomial (lookup0 f x) x)"
  including fmap.lifting
  by (auto intro!: poly_mapping_eqI sum.neutral
      simp: fmlookup_default_def lookup_sum lookup_single when_def fmdom'I
      split: option.splits)

lemma MPoly_numeral: "MPoly (numeral x) = numeral x"
  by (metis monom.abs_eq monom_numeral single_numeral)

lemma MPoly_power: "MPoly (x ^ n) = MPoly x ^ n"
  by (induction n) (auto simp: one_mpoly_def times_mpoly.abs_eq[symmetric])

lemmas [mpoly_simps] = Pm_fmap_sum
  add.assoc[symmetric] mult.assoc[symmetric]
  add_0 add_0_right mult_1 mult_1_right mult_zero_left mult_zero_right power_0 power_one_right
  fmdom'_fmap_of_list
  list.map fst_conv
  sum.insert_remove finite_insert finite.emptyI
  lookup0_fmap_of_list_simps
  num.simps rel_simps
  if_True if_False
  insert_Diff_if insert_iff empty_Diff empty_iff
  simp_thms
  sum.empty
  if_poly_mapping_eq_iff
  keys_zero keys_one
  keys_add_eq
  keys_single
  Un_insert_left Un_empty_left
  Int_insert_left Int_empty_left
  Collect_False
  lookup_add lookup_single lookup_zero lookup_one
  Set.ball_simps
  when_simps
  monomial_mp
  monomial1_add
  monomial1_monomial
  Const0_one Const0_zero Const0_numeral Const0_minus
  set_simps

text ‹A simproc for postprocessing with mpoly_simps› and not polluting [code_post]›:›

ML val mpoly_simproc = Simplifier.make_simproc @{context} "multivariate polynomials"
      {lhss = [@{term "Pm_fmap mpp::(_ 0 nat) 0 _"}],
       proc = (K (fn ctxt => fn ct =>
          SOME (Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps
            (Named_Theorems.get ctxt (named_theorems‹mpoly_simps›))) ct)))}

(* The simproc slows down computations *a lot*, so it is deactivated by default. *)

(* setup ‹Code_Preproc.map_post (fn ctxt => ctxt addsimprocs [mpoly_simproc])› *)


subsubsection ‹Ordered Power-Products›

lemma foldl_assoc:
  assumes "x y z. f (f x y) z = f x (f y z)"
  shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
  fix a b
  show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
  fix a b x xs
  assume "a b. foldl f (f a b) xs = f a (foldl f b xs)"
  from assms[of a b x] this[of a "f b x"]
    show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
qed

context ordered_term
begin

definition list_max::"'t list  't" where
  "list_max xs  foldl ord_term_lin.max min_term xs"

lemma list_max_Cons: "list_max (x # xs) = ord_term_lin.max x (list_max xs)"
  unfolding list_max_def foldl_Cons
proof -
  have "foldl ord_term_lin.max (ord_term_lin.max x min_term) xs =
          ord_term_lin.max x (foldl ord_term_lin.max min_term xs)"
    by (rule foldl_assoc, rule ord_term_lin.max.assoc)
  from this ord_term_lin.max.commute[of min_term x]
    show "foldl ord_term_lin.max (ord_term_lin.max min_term x) xs =
            ord_term_lin.max x (foldl ord_term_lin.max min_term xs)" by simp
qed

lemma list_max_empty: "list_max [] = min_term"
  unfolding list_max_def by simp

lemma list_max_in_list:
  assumes "xs  []"
  shows "list_max xs  set xs"
  using assms
proof (induct xs, simp)
  fix x xs
  assume IH: "xs  []  list_max xs  set xs"
  show "list_max (x # xs)  set (x # xs)"
  proof (cases "xs = []")
    case True
    hence "list_max (x # xs) = ord_term_lin.max min_term x" unfolding list_max_def by simp
    also have " = x" unfolding ord_term_lin.max_def by (simp add: min_term_min)
    finally show ?thesis by simp
  next
    assume "xs  []"
    show ?thesis
    proof (cases "x t list_max xs")
      case True
      hence "list_max (x # xs) = list_max xs"
        unfolding list_max_Cons ord_term_lin.max_def by simp
      thus ?thesis using IH[OF xs  []] by simp
    next
      case False
      hence "list_max (x # xs) = x" unfolding list_max_Cons ord_term_lin.max_def by simp
      thus ?thesis by simp
    qed
  qed
qed

lemma list_max_maximum:
  assumes "a  set xs"
  shows "a t (list_max xs)"
  using assms
proof (induct xs)
  assume "a  set []"
  thus "a t list_max []" by simp
next
  fix x xs
  assume IH: "a  set xs  a t list_max xs" and a_in: "a  set (x # xs)"
  from a_in have "a = x  a  set xs" by simp
  thus "a t list_max (x # xs)" unfolding list_max_Cons
  proof
    assume "a = x"
    thus "a t ord_term_lin.max x (list_max xs)" by simp
  next
    assume "a  set xs"
    from IH[OF this] show "a t ord_term_lin.max x (list_max xs)"
      by (simp add: ord_term_lin.le_max_iff_disj)
  qed
qed

lemma list_max_nonempty:
  assumes "xs  []"
  shows "list_max xs = ord_term_lin.Max (set xs)"
proof -
  have fin: "finite (set xs)" by simp
  have "ord_term_lin.Max (set xs) = list_max xs"
  proof (rule ord_term_lin.Max_eqI[OF fin, of "list_max xs"])
    fix y
    assume "y  set xs"
    from list_max_maximum[OF this] show "y t list_max xs" .
  next
    from list_max_in_list[OF assms] show "list_max xs  set xs" .
  qed
  thus ?thesis by simp
qed

lemma in_set_clearjunk_iff_map_of_eq_Some:
  "(a, b)  set (AList.clearjunk xs)  map_of xs a = Some b"
  by (metis Some_eq_map_of_iff distinct_clearjunk map_of_clearjunk)

lemma Pm_fmap_of_list_eq_zero_iff:
  "Pm_fmap (fmap_of_list xs) = 0  [(k, v)AList.clearjunk xs . v  0] = []"
  by (auto simp: poly_mapping_eq_iff fmlookup_default_def fun_eq_iff
    in_set_clearjunk_iff_map_of_eq_Some filter_empty_conv fmlookup_of_list split: option.splits)

lemma fmdom'_clearjunk0: "fmdom' (clearjunk0 xs) = fmdom' xs - {x. fmlookup xs x = Some 0}"
  by (metis (no_types, lifting) clearjunk0_def fmdom'_drop_set fmfilter_alt_defs(2) fmfilter_cong' mem_Collect_eq)

lemma compute_lt_poly_mapping[code]:
  "lt (Pm_fmap (fmap_of_list xs)) = list_max (map fst [(k, v)  AList.clearjunk xs. v  0])"
proof -
  have "keys (Pm_fmap (fmap_of_list xs)) = fst ` {x  set (AList.clearjunk xs). case x of (k, v)  v  0}"
    by (auto simp: compute_keys_pp fmdom'_clearjunk0 fmap_of_list.rep_eq
        in_set_clearjunk_iff_map_of_eq_Some fmdom'I image_iff fmlookup_dom'_iff)
  then show ?thesis
    unfolding lt_def
    by (auto simp: Pm_fmap_of_list_eq_zero_iff list_max_empty list_max_nonempty)
qed

lemma compute_higher_poly_mapping [code]:
  "higher (Pm_fmap xs) t = Pm_fmap (fmfilter (λk. t t k) xs)"
  unfolding higher_def compute_except_poly_mapping
  by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)

lemma compute_lower_poly_mapping [code]:
  "lower (Pm_fmap xs) t = Pm_fmap (fmfilter (λk. k t t) xs)"
  unfolding lower_def compute_except_poly_mapping
  by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)

end (* ordered_term *)

lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting

subsection ‹Computations›

subsubsection ‹Scalar Polynomials›

type_synonym 'a mpoly_tc = "(nat 0 nat)0'a"

definition "shift_map_keys_punit = term_powerprod.shift_map_keys to_pair_unit fst"

lemma compute_shift_map_keys_punit [code]:
  "shift_map_keys_punit t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (t + k, f v)) xs)"
  by (simp add: punit.compute_shift_map_keys shift_map_keys_punit_def)

global_interpretation punit: term_powerprod to_pair_unit fst
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (λx. x)"
  and "punit.component_of_term = (λ_. ())"
  defines monom_mult_punit = punit.monom_mult
  and mult_scalar_punit = punit.mult_scalar
  apply (fact MPoly_Type_Class.punit.term_powerprod_axioms)
  apply (fact MPoly_Type_Class.punit_adds_term)
  apply (fact MPoly_Type_Class.punit_pp_of_term)
  apply (fact MPoly_Type_Class.punit_component_of_term)
  done

lemma compute_monom_mult_punit [code]:
  "monom_mult_punit c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_punit t ((*) c) xs)"
  by (simp add: monom_mult_punit_def punit.compute_monom_mult_poly_mapping shift_map_keys_punit_def)

lemma compute_mult_scalar_punit [code]:
  "Pm_fmap (fmap_of_list xs) * q = (case xs of ((t, c) # ys) 
    (monom_mult_punit c t q + except (Pm_fmap (fmap_of_list ys)) {t} * q) | _ 
    Pm_fmap fmempty)"
  by (simp only: punit_mult_scalar[symmetric] punit.compute_mult_scalar_poly_mapping monom_mult_punit_def)

locale trivariate0_rat
begin

abbreviation X::"rat mpoly_tc" where "X  Var0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y  Var0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z  Var0 (2::nat)"

end

locale trivariate
begin

abbreviation "X  Var 0"
abbreviation "Y  Var 1"
abbreviation "Z  Var 2"

end

experiment begin interpretation trivariate0_rat .

lemma
  "keys (X2 * Z ^ 3 + 2 * Y ^ 3 * Z2) =
    {monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
  by eval

lemma
  "keys (X2 * Z ^ 3 + 2 * Y ^ 3 * Z2) =
    {monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
  by eval

lemma
  "- 1 * X2 * Z ^ 7 + - 2 * Y ^ 3 * Z2 = - X2 * Z ^ 7 + - 2 * Y ^ 3 * Z2"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 + X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2 = X2 * Z ^ 7 + X2 * Z ^ 4"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 - X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2 =
    X2 * Z ^ 7 - X2 * Z ^ 4"
  by eval

lemma
  "lookup (X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 + 2) (sparse0 [(0, 2), (2, 7)]) = 1"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 
   X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2"
  by eval


lemma
  "0 * X^2 * Z^7 + 0 * Y^3*Z2 = 0"
  by eval

lemma
  "monom_mult_punit 3 (sparse0 [(1, 2::nat)]) (X2 * Z + 2 * Y ^ 3 * Z2) =
    3 * Y2 * Z * X2 + 6 * Y ^ 5 * Z2"
  by eval

lemma
  "monomial (-4) (sparse0 [(0, 2::nat)]) = - 4 * X2"
  by eval

lemma "monomial (0::rat) (sparse0 [(0::nat, 2::nat)]) = 0"
  by eval

lemma
  "(X2 * Z + 2 * Y ^ 3 * Z2) * (X2 * Z ^ 3 + - 2 * Y ^ 3 * Z2) =
    X ^ 4 * Z ^ 4 + - 2 * X2 * Z ^ 3 * Y ^ 3 +
 - 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X2"
  by eval

end

subsubsection ‹Vector-Polynomials›

type_synonym 'a vmpoly_tc = "((nat 0 nat) × nat) 0 'a"

definition "shift_map_keys_pprod = pprod.shift_map_keys"

global_interpretation pprod: term_powerprod "λx. x" "λx. x"
  rewrites "pprod.pp_of_term = fst"
  and "pprod.component_of_term = snd"
  defines splus_pprod = pprod.splus
  and monom_mult_pprod = pprod.monom_mult
  and mult_scalar_pprod = pprod.mult_scalar
  and adds_term_pprod = pprod.adds_term
  apply (fact MPoly_Type_Class.pprod.term_powerprod_axioms)
  apply (fact MPoly_Type_Class.pprod_pp_of_term)
  apply (fact MPoly_Type_Class.pprod_component_of_term)
  done

lemma compute_adds_term_pprod [code_unfold]:
  "adds_term_pprod u v = (snd u = snd v  adds_pp_add_linorder (fst u) (fst v))"
  by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)

lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
  by (simp add: splus_pprod_def pprod.splus_def)

lemma compute_shift_map_keys_pprod [code]:
  "shift_map_keys_pprod t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (splus_pprod t k, f v)) xs)"
  by (simp add: pprod.compute_shift_map_keys shift_map_keys_pprod_def splus_pprod_def)

lemma compute_monom_mult_pprod [code]:
  "monom_mult_pprod c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_pprod t ((*) c) xs)"
  by (simp add: monom_mult_pprod_def pprod.compute_monom_mult_poly_mapping shift_map_keys_pprod_def)

lemma compute_mult_scalar_pprod [code]:
  "mult_scalar_pprod (Pm_fmap (fmap_of_list xs)) q = (case xs of ((t, c) # ys) 
    (monom_mult_pprod c t q + mult_scalar_pprod (except (Pm_fmap (fmap_of_list ys)) {t}) q) | _ 
    Pm_fmap fmempty)"
  by (simp only: mult_scalar_pprod_def pprod.compute_mult_scalar_poly_mapping monom_mult_pprod_def)

definition Vec0 :: "nat  (('a 0 nat) 0 'b)  (('a 0 nat) × nat) 0 'b::semiring_1" where
  "Vec0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"

experiment begin interpretation trivariate0_rat .

lemma
  "keys (Vec0 0 (X2 * Z ^ 3) + Vec0 1 (2 * Y ^ 3 * Z2)) =
    {(sparse0 [(0, 2), (2, 3)], 0), (sparse0 [(1, 3), (2, 2)], 1)}"
  by eval

lemma
  "keys (Vec0 0 (X2 * Z ^ 3) + Vec0 2 (2 * Y ^ 3 * Z2)) =
    {(sparse0 [(0, 2), (2, 3)], 0), (sparse0 [(1, 3), (2, 2)], 2)}"
  by eval

lemma
  "Vec0 1 (X2 * Z ^ 7 + 2 * Y ^ 3 * Z2) + Vec0 3 (X2 * Z ^ 4) + Vec0 1 (- 2 * Y ^ 3 * Z2) =
    Vec0 1 (X2 * Z ^ 7) + Vec0 3 (X2 * Z ^ 4)"
  by eval

lemma
  "lookup (Vec0 0 (X2 * Z ^ 7) + Vec0 1 (2 * Y ^ 3 * Z2 + 2)) (sparse0 [(0, 2), (2, 7)], 0) = 1"
  by eval

lemma
  "lookup (Vec0 0 (X2 * Z ^ 7) + Vec0 1 (2 * Y ^ 3 * Z2 + 2)) (sparse0 [(0, 2), (2, 7)], 1) = 0"
  by eval

lemma
  "Vec0 0 (0 * X^2 * Z^7) + Vec0 1 (0 * Y^3*Z2) = 0"
  by eval

lemma
  "monom_mult_pprod 3 (sparse0 [(1, 2::nat)]) (Vec0 0 (X2 * Z) + Vec0 1 (2 * Y ^ 3 * Z2)) =
    Vec0 0 (3 * Y2 * Z * X2) + Vec0 1 (6 * Y ^ 5 * Z2)"
  by eval

end

subsection ‹Code setup for type MPoly›

text ‹postprocessing from Var0, Const0 to Var, Const›.›

lemmas [code_post] =
  plus_mpoly.abs_eq[symmetric]
  times_mpoly.abs_eq[symmetric]
  MPoly_numeral
  MPoly_power
  one_mpoly_def[symmetric]
  Var.abs_eq[symmetric]
  Const.abs_eq[symmetric]

instantiation mpoly::("{equal, zero}")equal begin

lift_definition equal_mpoly:: "'a mpoly  'a mpoly  bool" is HOL.equal .

instance proof standard qed (transfer, rule equal_eq)

end

experiment begin interpretation trivariate .

lemmas [mpoly_simps] = plus_mpoly.abs_eq

lemma "content_primitive (4 * X * Y^2 * Z^3 + 6 * X2 * Y^4 + 8 * X2 * Y^5) =
    (2::int, 2 * X * Y2 * Z ^ 3 + 3 * X2 * Y ^ 4 + 4 * X2 * Y ^ 5)"
  by eval

end

end (* theory *)

Theory PP_Type

(* Author: Alexander Maletzky *)

theory PP_Type
  imports Power_Products
begin

text ‹For code generation, we must introduce a copy of type @{typ "'a 0 'b"} for power-products.›

typedef (overloaded) ('a, 'b) pp = "UNIV::('a 0 'b) set"
  morphisms mapping_of PP ..

setup_lifting type_definition_pp

lift_definition pp_of_fun :: "('a  'b)  ('a, 'b::zero) pp"
  is Abs_poly_mapping .

subsection lookup_pp›, keys_pp› and single_pp›

lift_definition lookup_pp :: "('a, 'b::zero) pp  'a  'b" is lookup .

lift_definition keys_pp :: "('a, 'b::zero) pp  'a set" is keys .

lift_definition single_pp :: "'a  'b  ('a, 'b::zero) pp" is Poly_Mapping.single .

lemma lookup_pp_of_fun: "finite {x. f x  0}  lookup_pp (pp_of_fun f) = f"
  by (transfer, rule Abs_poly_mapping_inverse, simp)

lemma pp_of_lookup: "pp_of_fun (lookup_pp t) = t"
  by (transfer, fact lookup_inverse)

lemma pp_eqI: "(u. lookup_pp s u = lookup_pp t u)  s = t"
  by (transfer, rule poly_mapping_eqI)

lemma pp_eq_iff: "(s = t)  (lookup_pp s = lookup_pp t)"
  by (auto intro: pp_eqI)

lemma keys_pp_iff: "x  keys_pp t  (lookup_pp t x  0)"
  by (simp add: in_keys_iff keys_pp.rep_eq lookup_pp.rep_eq)

lemma pp_eqI':
  assumes "u. u  keys_pp s  keys_pp t  lookup_pp s u = lookup_pp t u"
  shows "s = t"
proof (rule pp_eqI)
  fix u
  show "lookup_pp s u = lookup_pp t u"
  proof (cases "u  keys_pp s  keys_pp t")
    case True
    thus ?thesis by (rule assms)
  next
    case False
    thus ?thesis by (simp add: keys_pp_iff)
  qed
qed

lemma lookup_single_pp: "lookup_pp (single_pp x e) y = (e when x = y)"
  by (transfer, simp only: lookup_single)

subsection ‹Additive Structure›

instantiation pp :: (type, zero) zero
begin

lift_definition zero_pp :: "('a, 'b) pp" is "0::'a 0 'b" .

lemma lookup_zero_pp [simp]: "lookup_pp 0 = 0"
  by (transfer, simp add: lookup_zero_fun)

instance ..

end

lemma single_pp_zero [simp]: "single_pp x 0 = 0"
  by (rule pp_eqI, simp add: lookup_single_pp)

instantiation pp :: (type, monoid_add) monoid_add
begin

lift_definition plus_pp :: "('a, 'b) pp  ('a, 'b) pp  ('a, 'b) pp" is "(+)::('a 0 'b)  _" .

lemma lookup_plus_pp: "lookup_pp (s + t) = lookup_pp s + lookup_pp t"
  by (transfer, simp add: lookup_plus_fun)

instance by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+

end

lemma single_pp_plus: "single_pp x a + single_pp x b = single_pp x (a + b)"
  by (rule pp_eqI, simp add: lookup_single_pp lookup_plus_pp when_def)

instance pp :: (type, comm_monoid_add) comm_monoid_add
  by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+

instantiation pp :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
begin

lift_definition minus_pp :: "('a, 'b) pp  ('a, 'b) pp  ('a, 'b) pp" is "(-)::('a 0 'b)  _" .

lemma lookup_minus_pp: "lookup_pp (s - t) = lookup_pp s - lookup_pp t"
  by (transfer, simp only: lookup_minus_fun)

instance by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+

end

subsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}

instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
  by standard

subsection @{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}

instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
  fix s t::"'a  'b"
  assume "(λk. s k + t k) = (λ_. 0)"
  hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
  hence "s = 0" by (rule plus_eq_zero)
  thus "s = (λ_. 0)" by (simp only: zero_fun_def)
qed

subsection @{typ "('a, 'b) pp"} belongs to class @{class lcs_powerprod}

lemma adds_pp_iff: "(s adds t)  (mapping_of s adds mapping_of t)"
  unfolding adds_def by (transfer, fact refl)

instantiation pp :: (type, add_linorder) lcs_powerprod
begin

lift_definition lcs_pp :: "('a, 'b) pp  ('a, 'b) pp  ('a, 'b) pp" is "lcs_powerprod_class.lcs" .

lemma lookup_lcs_pp: "lookup_pp (lcs s t) x = max (lookup_pp s x) (lookup_pp t x)"
  by (transfer, simp add: lookup_lcs_fun lcs_fun_def)

instance
  apply (intro_classes, simp_all only: adds_pp_iff)
  subgoal by (transfer, rule adds_lcs)
  subgoal by (transfer, elim lcs_adds)
  subgoal by (transfer, rule lcs_comm)
  done

end

subsection @{typ "('a, 'b) pp"} belongs to class @{class ulcs_powerprod}

instance pp :: (type, add_linorder_min) ulcs_powerprod by intro_classes (transfer, elim plus_eq_zero)

subsection ‹Dickson's lemma for power-products in finitely many indeterminates›

lemma almost_full_on_pp_iff:
  "almost_full_on (adds) A  almost_full_on (adds) (mapping_of ` A)" (is "?l  ?r")
proof
  assume ?l
  with _ show ?r
  proof (rule almost_full_on_hom)
    fix x y :: "('a, 'b) pp"
    assume "x adds y"
    thus "mapping_of x adds mapping_of y" by (simp only: adds_pp_iff)
  qed
next
  assume ?r
  hence "almost_full_on (λx y. mapping_of x adds mapping_of y) A"
    using subset_refl by (rule almost_full_on_map)
  thus ?l by (simp only: adds_pp_iff[symmetric])
qed

lift_definition varnum_pp :: "('a::countable, 'b::zero) pp  nat" is "varnum {}" .

lemma dickson_grading_varnum_pp:
  "dickson_grading (varnum_pp::('a::countable, 'b::add_wellorder) pp  nat)"
proof (rule dickson_gradingI)
  fix s t :: "('a, 'b) pp"
  show "varnum_pp (s + t) = max (varnum_pp s) (varnum_pp t)" by (transfer, rule varnum_plus)
next
  fix m::nat
  show "almost_full_on (adds) {x::('a, 'b) pp. varnum_pp x  m}" unfolding almost_full_on_pp_iff
  proof (transfer, simp)
    fix m::nat
    from dickson_grading_varnum_empty show "almost_full_on (adds) {x::'a 0 'b. varnum {} x  m}"
      by (rule dickson_gradingD2)
  qed
qed

instance pp :: (countable, add_wellorder) graded_dickson_powerprod
  by (standard, rule, fact dickson_grading_varnum_pp)

instance pp :: (finite, add_wellorder) dickson_powerprod
proof
  have eq: "range mapping_of = UNIV" by (rule surjI, rule PP_inverse, rule UNIV_I)
  show "almost_full_on (adds) (UNIV::('a, 'b) pp set)" by (simp add: almost_full_on_pp_iff eq dickson)
qed

subsection ‹Lexicographic Term Order›

lift_definition lex_pp :: "('a, 'b) pp  ('a::linorder, 'b::{zero,linorder}) pp  bool" is lex_pm .

lift_definition lex_pp_strict :: "('a, 'b) pp  ('a::linorder, 'b::{zero,linorder}) pp  bool" is lex_pm_strict .

lemma lex_pp_alt: "lex_pp s t = (s = t  (x. lookup_pp s x < lookup_pp t x  (y<x. lookup_pp s y = lookup_pp t y)))"
  by (transfer, fact lex_pm_alt)

lemma lex_pp_refl: "lex_pp s s"
  by (transfer, fact lex_pm_refl)

lemma lex_pp_antisym: "lex_pp s t  lex_pp t s  s = t"
  by (transfer, intro lex_pm_antisym)

lemma lex_pp_trans: "lex_pp s t  lex_pp t u  lex_pp s u"
  by (transfer, rule lex_pm_trans)

lemma lex_pp_lin: "lex_pp s t  lex_pp t s"
  by (transfer, fact lex_pm_lin)

lemma lex_pp_lin': "¬ lex_pp t s  lex_pp s t"
  using lex_pp_lin by blast ―‹Better suited for auto›.›

corollary lex_pp_strict_alt [code]:
  "lex_pp_strict s t = (¬ lex_pp t s)" for s t::"(_, _::ordered_comm_monoid_add) pp"
  by (transfer, fact lex_pm_strict_alt)

lemma lex_pp_zero_min: "lex_pp 0 s" for s::"(_, _::add_linorder_min) pp"
  by (transfer, fact lex_pm_zero_min)

lemma lex_pp_plus_monotone: "lex_pp s t  lex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
  by (transfer, intro lex_pm_plus_monotone)

lemma lex_pp_plus_monotone': "lex_pp s t  lex_pp (u + s) (u + t)"
  for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
  unfolding add.commute[of u] by (rule lex_pp_plus_monotone)

instantiation pp :: (linorder, "{ordered_comm_monoid_add, linorder}") linorder
begin

definition less_eq_pp :: "('a, 'b) pp  ('a, 'b) pp  bool"
  where "less_eq_pp = lex_pp"

definition less_pp :: "('a, 'b) pp  ('a, 'b) pp  bool"
  where "less_pp = lex_pp_strict"

instance by intro_classes (auto simp: less_eq_pp_def less_pp_def lex_pp_refl lex_pp_strict_alt intro: lex_pp_antisym lex_pp_lin' elim: lex_pp_trans)

end

subsection ‹Degree›

lift_definition deg_pp :: "('a, 'b::comm_monoid_add) pp  'b" is deg_pm .

lemma deg_pp_alt: "deg_pp s = sum (lookup_pp s) (keys_pp s)"
  by (transfer, transfer, simp add: deg_fun_def supp_fun_def)

lemma deg_pp_zero [simp]: "deg_pp 0 = 0"
  by (transfer, fact deg_pm_zero)

lemma deg_pp_eq_0_iff [simp]: "deg_pp s = 0  s = 0" for s::"('a, 'b::add_linorder_min) pp"
  by (transfer, fact deg_pm_eq_0_iff)

lemma deg_pp_plus: "deg_pp (s + t) = deg_pp s + deg_pp (t::('a, 'b::comm_monoid_add) pp)"
  by (transfer, fact deg_pm_plus)

lemma deg_pp_single: "deg_pp (single_pp x k) = k"
  by (transfer, fact deg_pm_single)

subsection ‹Degree-Lexicographic Term Order›

lift_definition dlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp  ('a, 'b) pp  bool"
  is dlex_pm .

lift_definition dlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp  ('a, 'b) pp  bool"
  is dlex_pm_strict .

lemma dlex_pp_alt: "dlex_pp s t  (deg_pp s < deg_pp t  (deg_pp s = deg_pp t  lex_pp s t))"
  by transfer (simp only: dlex_pm_def dord_pm_alt)

lemma dlex_pp_refl: "dlex_pp s s"
  by (transfer) (fact dlex_pm_refl)

lemma dlex_pp_antisym: "dlex_pp s t  dlex_pp t s  s = t"
  by (transfer, elim dlex_pm_antisym)

lemma dlex_pp_trans: "dlex_pp s t  dlex_pp t u  dlex_pp s u"
  by (transfer, rule dlex_pm_trans)

lemma dlex_pp_lin: "dlex_pp s t  dlex_pp t s"
  by (transfer, fact dlex_pm_lin)

corollary dlex_pp_strict_alt [code]: "dlex_pp_strict s t = (¬ dlex_pp t s)"
  by (transfer, fact dlex_pm_strict_alt)

lemma dlex_pp_zero_min: "dlex_pp 0 s"
  for s t::"(_, _::add_linorder_min) pp"
  by (transfer, fact dlex_pm_zero_min)

lemma dlex_pp_plus_monotone: "dlex_pp s t  dlex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
  by (transfer, rule dlex_pm_plus_monotone)

subsection ‹Degree-Reverse-Lexicographic Term Order›

lift_definition drlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp  ('a, 'b) pp  bool"
  is drlex_pm .

lift_definition drlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp  ('a, 'b) pp  bool"
  is drlex_pm_strict .

lemma drlex_pp_alt: "drlex_pp s t  (deg_pp s < deg_pp t  (deg_pp s = deg_pp t  lex_pp t s))"
  by transfer (simp only: drlex_pm_def dord_pm_alt)

lemma drlex_pp_refl: "drlex_pp s s"
  by (transfer, fact drlex_pm_refl)

lemma drlex_pp_antisym: "drlex_pp s t  drlex_pp t s  s = t"
  by (transfer, rule drlex_pm_antisym)

lemma drlex_pp_trans: "drlex_pp s t  drlex_pp t u  drlex_pp s u"
  by (transfer, rule drlex_pm_trans)

lemma drlex_pp_lin: "drlex_pp s t  drlex_pp t s"
  by (transfer, fact drlex_pm_lin)

corollary drlex_pp_strict_alt [code]: "drlex_pp_strict s t = (¬ drlex_pp t s)"
  by (transfer, fact drlex_pm_strict_alt)

lemma drlex_pp_zero_min: "drlex_pp 0 s"
  for s t::"(_, _::add_linorder_min) pp"
  by (transfer, fact drlex_pm_zero_min)

lemma drlex_pp_plus_monotone: "drlex_pp s t  drlex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
  by (transfer, rule drlex_pm_plus_monotone)

end (* theory *)

Theory OAlist

(* Author: Florian Haftmann, TU Muenchen *)
(* Author: Andreas Lochbihler, ETH Zurich *)
(* Author: Alexander Maletzky, RISC Linz *)

section ‹Associative Lists with Sorted Keys›

theory OAlist
  imports Deriving.Comparator
begin

text ‹We define the type of @{emph ‹ordered associative lists›} (oalist). An oalist is an associative
  list (i.\,e. a list of pairs) such that the keys are distinct and sorted wrt. some linear
  order relation, and no key is mapped to @{term 0}. The latter invariant allows to implement various
  functions operating on oalists more efficiently.

  The ordering of the keys in an oalist xs› is encoded as an additional parameter of xs›.
  This means that oalists may be ordered wrt. different orderings, even if they are of the same type.
  Operations operating on more than one oalists, like map2_val›, typically ensure that the orderings
  of their arguments are identical by re-ordering one argument wrt. the order relation of the other.
  This, however, implies that equality of order relations must be effectively decidable if executable
  code is to be generated.›

subsection ‹Preliminaries›

fun min_list_param :: "('a  'a  bool)  'a list  'a" where
  "min_list_param rel (x # xs) = (case xs of []  x | _  (let m = min_list_param rel xs in if rel x m then x else m))"

lemma min_list_param_in:
  assumes "xs  []"
  shows "min_list_param rel xs  set xs"
  using assms
proof (induct xs)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
        intro conjI impI allI, simp, simp)
    fix y ys
    assume xs: "xs = y # ys"
    have "min_list_param rel (y # ys) = min_list_param rel xs" by (simp only: xs)
    also have "...  set xs" by (rule Cons(1), simp add: xs)
    also have "...  set (x # y # ys)" by (auto simp: xs)
    finally show "min_list_param rel (y # ys)  set (x # y # ys)" .
  qed
qed

lemma min_list_param_minimal:
  assumes "transp rel" and "x y. x  set xs  y  set xs  rel x y  rel y x"
    and "z  set xs"
  shows "rel (min_list_param rel xs) z"
  using assms(2, 3)
proof (induct xs)
  case Nil
  from Nil(2) show ?case by simp
next
  case (Cons x xs)
  from Cons(3) have disj1: "z = x  z  set xs" by simp
  have "x  set (x # xs)" by simp
  hence disj2: "rel x z  rel z x" using Cons(3) by (rule Cons(2))
  have *: "rel (min_list_param rel xs) z" if "z  set xs" using _ that
  proof (rule Cons(1))
    fix a b
    assume "a  set xs" and "b  set xs"
    hence "a  set (x # xs)" and "b  set (x # xs)" by simp_all
    thus "rel a b  rel b a" by (rule Cons(2))
  qed
  show ?case
  proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
        intro conjI impI allI)
    assume "xs = []"
    with disj1 disj2 show "rel x z" by simp
  next
    fix y ys
    assume "xs = y # ys" and "rel x (min_list_param rel (y # ys))"
    hence "rel x (min_list_param rel xs)" by simp
    from disj1 show "rel x z"
    proof
      assume "z = x"
      thus ?thesis using disj2 by simp
    next
      assume "z  set xs"
      hence "rel (min_list_param rel xs) z" by (rule *)
      with assms(1) rel x (min_list_param rel xs) show ?thesis by (rule transpD)
    qed
  next
    fix y ys
    assume xs: "xs = y # ys" and "¬ rel x (min_list_param rel (y # ys))"
    from disj1 show "rel (min_list_param rel (y # ys)) z"
    proof
      assume "z = x"
      have "min_list_param rel (y # ys)  set (y # ys)" by (rule min_list_param_in, simp)
      hence "min_list_param rel (y # ys)  set (x # xs)" by (simp add: xs)
      with x  set (x # xs) have "rel x (min_list_param rel (y # ys))  rel (min_list_param rel (y # ys)) x"
        by (rule Cons(2))
      with ¬ rel x (min_list_param rel (y # ys)) have "rel (min_list_param rel (y # ys)) x" by simp
      thus ?thesis by (simp only: z = x)
    next
      assume "z  set xs"
      hence "rel (min_list_param rel xs) z" by (rule *)
      thus ?thesis by (simp only: xs)
    qed
  qed
qed

definition comp_of_ord :: "('a  'a  bool)  'a comparator" where
  "comp_of_ord le x y = (if le x y then if x = y then Eq else Lt else Gt)"

lemma comp_of_ord_eq_comp_of_ords:
  assumes "antisymp le"
  shows "comp_of_ord le = comp_of_ords le (λx y. le x y  ¬ le y x)"
  by (intro ext, auto simp: comp_of_ord_def comp_of_ords_def intro: assms antisympD)

lemma comparator_converse:
  assumes "comparator cmp"
  shows "comparator (λx y. cmp y x)"
proof -
  from assms interpret comp?: comparator cmp .
  show ?thesis by (unfold_locales, auto simp: comp.eq comp.sym intro: comp_trans)
qed

lemma comparator_composition:
  assumes "comparator cmp" and "inj f"
  shows "comparator (λx y. cmp (f x) (f y))"
proof -
  from assms(1) interpret comp?: comparator cmp .
  from assms(2) have *: "x = y" if "f x = f y" for x y using that by (rule injD)
  show ?thesis by (unfold_locales, auto simp: comp.sym comp.eq * intro: comp_trans)
qed

(*
subsection ‹Syntactic Type Class for Default Elements›

text ‹We do not want to use the existing type-class @{class default}, but instead introduce a new one:›

class oalist_dflt = fixes dflt::'a

simproc_setup reorient_dflt ("dflt = x") = Reorient_Proc.proc
*)

subsection ‹Type key_order›

typedef 'a key_order = "{compare :: 'a comparator. comparator compare}"
  morphisms key_compare Abs_key_order
proof -
  from well_order_on obtain r where "well_order_on (UNIV::'a set) r" ..
  hence "linear_order r" by (simp only: well_order_on_def)
  hence lin: "(x, y)  r  (y, x)  r" for x y
    by (metis Diff_iff Linear_order_in_diff_Id UNIV_I ‹well_order r well_order_on_Field)
  have antisym: "(x, y)  r  (y, x)  r  x = y" for x y
    by (meson ‹linear_order r antisymD linear_order_on_def partial_order_on_def)
  have trans: "(x, y)  r  (y, z)  r  (x, z)  r" for x y z
    by (meson ‹linear_order r linear_order_on_def order_on_defs(1) partial_order_on_def trans_def)
  define comp where "comp = (λx y. if (x, y)  r then if (y, x)  r then Eq else Lt else Gt)"
  show ?thesis
  proof (rule, simp)
    show "comparator comp"
    proof (standard, simp_all add: comp_def split: if_splits, intro impI)
      fix x y
      assume "(x, y)  r" and "(y, x)  r"
      thus "x = y" by (rule antisym)
    next
      fix x y
      assume "(x, y)  r"
      with lin show "(y, x)  r" by blast
    next
      fix x y z
      assume "(y, x)  r" and "(z, y)  r"
      assume "(x, y)  r" and "(y, z)  r"
      hence "(x, z)  r" by (rule trans)
      moreover have "(z, x)  r"
      proof
        assume "(z, x)  r"
        with (x, z)  r have "x = z" by (rule antisym)
        from (z, y)  r (x, y)  r show False unfolding x = z ..
      qed
      ultimately show "(z, x)  r  ((z, x)  r  (x, z)  r)" by simp
    qed
  qed
qed

lemma comparator_key_compare [simp, intro!]: "comparator (key_compare ko)"
  using key_compare[of ko] by simp

instantiation key_order :: (type) equal
begin

definition equal_key_order :: "'a key_order  'a key_order  bool" where "equal_key_order = (=)"

instance by (standard, simp add: equal_key_order_def)

end

setup_lifting type_definition_key_order

instantiation key_order :: (type) uminus
begin

lift_definition uminus_key_order :: "'a key_order  'a key_order" is "λc x y. c y x"
  by (fact comparator_converse)

instance ..

end

lift_definition le_of_key_order :: "'a key_order  'a  'a  bool" is "λcmp. le_of_comp cmp" .

lift_definition lt_of_key_order :: "'a key_order  'a  'a  bool" is "λcmp. lt_of_comp cmp" .

definition key_order_of_ord :: "('a  'a  bool)  'a key_order"
  where "key_order_of_ord ord = Abs_key_order (comp_of_ord ord)"

lift_definition key_order_of_le :: "'a::linorder key_order" is comparator_of
  by (fact comparator_of)

interpretation key_order_lin: linorder "le_of_key_order ko" "lt_of_key_order ko"
proof transfer
  fix comp::"'a comparator"
  assume "comparator comp"
  then interpret comp: comparator comp .
  show "class.linorder comp.le comp.lt" by (fact comp.linorder)
qed

lemma le_of_key_order_alt: "le_of_key_order ko x y = (key_compare ko x y  Gt)"
  by (transfer, simp add: comparator.nGt_le_conv)

lemma lt_of_key_order_alt: "lt_of_key_order ko x y = (key_compare ko x y = Lt)"
  by (transfer, meson comparator.Lt_lt_conv)

lemma key_compare_Gt: "key_compare ko x y = Gt  key_compare ko y x = Lt"
  by (transfer, meson comparator.nGt_le_conv comparator.nLt_le_conv)

lemma key_compare_Eq: "key_compare ko x y = Eq  x = y"
  by (transfer, simp add: comparator.eq)

lemma key_compare_same [simp]: "key_compare ko x x = Eq"
  by (simp add: key_compare_Eq)

lemma uminus_key_compare [simp]: "invert_order (key_compare ko x y) = key_compare ko y x"
  by (transfer, simp add: comparator.sym)

lemma key_compare_uminus [simp]: "key_compare (- ko) x y = key_compare ko y x"
  by (transfer, rule refl)

lemma uminus_key_order_sameD:
  assumes "- ko = (ko::'a key_order)"
  shows "x = (y::'a)"
proof (rule ccontr)
  assume "x  y"
  hence "key_compare ko x y  Eq" by (simp add: key_compare_Eq)
  hence "key_compare ko x y  invert_order (key_compare ko x y)"
    by (metis invert_order.elims order.distinct(5))
  also have "invert_order (key_compare ko x y) = key_compare (- ko) x y" by simp
  finally have "- ko  ko" by (auto simp del: key_compare_uminus)
  thus False using assms ..
qed

lemma key_compare_key_order_of_ord:
  assumes "antisymp ord" and "transp ord" and "x y. ord x y  ord y x"
  shows "key_compare (key_order_of_ord ord) = (λx y. if ord x y then if x = y then Eq else Lt else Gt)"
proof -
  have eq: "key_compare (key_order_of_ord ord) = comp_of_ord ord"
    unfolding key_order_of_ord_def comp_of_ord_eq_comp_of_ords[OF assms(1)]
  proof (rule Abs_key_order_inverse, simp, rule comp_of_ords, unfold_locales)
    fix x
    from assms(3) show "ord x x" by blast
  next
    fix x y z
    assume "ord x y" and "ord y z"
    with assms(2) show "ord x z" by (rule transpD)
  next
    fix x y
    assume "ord x y" and "ord y x"
    with assms(1) show "x = y" by (rule antisympD)
  qed (rule refl, rule assms(3))
  have *: "x = y" if "ord x y" and "ord y x" for x y using assms(1) that by (rule antisympD)
  show ?thesis by (rule, rule, auto simp: eq comp_of_ord_def intro: *)
qed

lemma key_compare_key_order_of_le:
  "key_compare key_order_of_le = (λx y. if x < y then Lt else if x = y then Eq else Gt)"
  by (transfer, intro ext, fact comparator_of_def)

subsection ‹Invariant in Context @{locale comparator}

context comparator
begin

definition oalist_inv_raw :: "('a × 'b::zero) list  bool"
  where "oalist_inv_raw xs  (0  snd ` set xs  sorted_wrt lt (map fst xs))"

lemma oalist_inv_rawI:
  assumes "0  snd ` set xs" and "sorted_wrt lt (map fst xs)"
  shows "oalist_inv_raw xs"
  unfolding oalist_inv_raw_def using assms unfolding fst_conv snd_conv by blast

lemma oalist_inv_rawD1:
  assumes "oalist_inv_raw xs"
  shows "0  snd ` set xs"
  using assms unfolding oalist_inv_raw_def fst_conv by blast

lemma oalist_inv_rawD2:
  assumes "oalist_inv_raw xs"
  shows "sorted_wrt lt (map fst xs)"
  using assms unfolding oalist_inv_raw_def fst_conv snd_conv by blast

lemma oalist_inv_raw_Nil: "oalist_inv_raw []"
  by (simp add: oalist_inv_raw_def)

lemma oalist_inv_raw_singleton: "oalist_inv_raw [(k, v)]  (v  0)"
  by (auto simp: oalist_inv_raw_def)

lemma oalist_inv_raw_ConsI:
  assumes "oalist_inv_raw xs" and "v  0" and "xs  []  lt k (fst (hd xs))"
  shows "oalist_inv_raw ((k, v) # xs)"
proof (rule oalist_inv_rawI)
  from assms(1) have "0  snd ` set xs" by (rule oalist_inv_rawD1)
  with assms(2) show "0  snd ` set ((k, v) # xs)" by simp
next
  show "sorted_wrt lt (map fst ((k, v) # xs))"
  proof (cases "xs = []")
    case True
    thus ?thesis by simp
  next
    case False
    then obtain k' v' xs' where xs: "xs = (k', v') # xs'" by (metis list.exhaust prod.exhaust)
    from assms(3)[OF False] have "lt k k'" by (simp add: xs)
    moreover from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
    ultimately show "sorted_wrt lt (map fst ((k, v) # xs))"
      by (simp add: xs sorted_wrt2[OF transp_less] del: sorted_wrt.simps)
  qed
qed

lemma oalist_inv_raw_ConsD1:
  assumes "oalist_inv_raw (x # xs)"
  shows "oalist_inv_raw xs"
proof (rule oalist_inv_rawI)
  from assms have "0  snd ` set (x # xs)" by (rule oalist_inv_rawD1)
  thus "0  snd ` set xs" by simp
next
  from assms have "sorted_wrt lt (map fst (x # xs))" by (rule oalist_inv_rawD2)
  thus "sorted_wrt lt (map fst xs)" by simp
qed

lemma oalist_inv_raw_ConsD2:
  assumes "oalist_inv_raw ((k, v) # xs)"
  shows "v  0"
proof -
  from assms have "0  snd ` set ((k, v) # xs)" by (rule oalist_inv_rawD1)
  thus ?thesis by auto
qed

lemma oalist_inv_raw_ConsD3:
  assumes "oalist_inv_raw ((k, v) # xs)" and "k'  fst ` set xs"
  shows "lt k k'"
proof -
  from assms(2) obtain x where "x  set xs" and "k' = fst x" by fastforce
  from assms(1) have "sorted_wrt lt (map fst ((k, v) # xs))" by (rule oalist_inv_rawD2)
  hence "xset xs. lt k (fst x)" by simp
  hence "lt k (fst x)" using x  set xs ..
  thus ?thesis by (simp only: k' = fst x)
qed

lemma oalist_inv_raw_tl:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (tl xs)"
proof (rule oalist_inv_rawI)
  from assms have "0  snd ` set xs" by (rule oalist_inv_rawD1)
  thus "0  snd ` set (tl xs)" by (metis (no_types, lifting) image_iff list.set_sel(2) tl_Nil)
next
  show "sorted_wrt lt (map fst (tl xs))"
    by (metis hd_Cons_tl oalist_inv_rawD2 oalist_inv_raw_ConsD1 assms tl_Nil)
qed

lemma oalist_inv_raw_filter:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (filter P xs)"
proof (rule oalist_inv_rawI)
  from assms have "0  snd ` set xs" by (rule oalist_inv_rawD1)
  thus "0  snd ` set (filter P xs)" by auto
next
  from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
  thus "sorted_wrt lt (map fst (filter P xs))" by (induct xs, simp, simp)
qed

lemma oalist_inv_raw_map:
  assumes "oalist_inv_raw xs"
    and "a. snd (f a) = 0  snd a = 0"
    and "a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
  shows "oalist_inv_raw (map f xs)"
proof (rule oalist_inv_rawI)
  show "0  snd ` set (map f xs)"
  proof (simp, rule)
    assume "0  snd ` f ` set xs"
    then obtain a where "a  set xs" and "snd (f a) = 0" by fastforce
    from this(2) have "snd a = 0" by (rule assms(2))
    from assms(1) have "0  snd ` set xs" by (rule oalist_inv_rawD1)
    moreover from a  set xs have "0  snd ` set xs" by (simp add: ‹snd a = 0[symmetric])
    ultimately show False ..
  qed
next
  from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
  hence "sorted_wrt (λx y. comp (fst x) (fst y) = Lt) xs"
    by (simp only: sorted_wrt_map Lt_lt_conv)
  thus "sorted_wrt lt (map fst (map f xs))"
    by (simp add: sorted_wrt_map Lt_lt_conv[symmetric] assms(3))
qed

lemma oalist_inv_raw_induct [consumes 1, case_names Nil Cons]:
  assumes "oalist_inv_raw xs"
  assumes "P []"
  assumes "k v xs. oalist_inv_raw ((k, v) # xs)  oalist_inv_raw xs  v  0 
              (k'. k'  fst ` set xs  lt k k')  P xs  P ((k, v) # xs)"
  shows "P xs"
  using assms(1)
proof (induct xs)
  case Nil
  from assms(2) show ?case .
next
  case (Cons x xs)
  obtain k v where x: "x = (k, v)" by fastforce
  from Cons(2) have "oalist_inv_raw ((k, v) # xs)" and "oalist_inv_raw xs" and "v  0" unfolding x
    by (this, rule oalist_inv_raw_ConsD1, rule oalist_inv_raw_ConsD2)
  moreover from Cons(2) have "lt k k'" if "k'  fst ` set xs" for k' using that
    unfolding x by (rule oalist_inv_raw_ConsD3)
  moreover from ‹oalist_inv_raw xs have "P xs" by (rule Cons(1))
  ultimately show ?case unfolding x by (rule assms(3))
qed

subsection ‹Operations on Lists of Pairs in Context @{locale comparator}

type_synonym (in -) ('a, 'b) comp_opt = "'a  'b  (order option)"

definition (in -) lookup_dflt :: "('a × 'b) list  'a  'b::zero"
  where "lookup_dflt xs k = (case map_of xs k of Some v  v | None  0)"

text @{const lookup_dflt} is only an auxiliary function needed for proving some lemmas.›

fun lookup_pair :: "('a × 'b) list  'a  'b::zero"
where
  "lookup_pair [] x = 0"|
  "lookup_pair ((k, v) # xs) x =
    (case comp x k of
       Lt  0
     | Eq  v
     | Gt  lookup_pair xs x)"

fun update_by_pair :: "('a × 'b)  ('a × 'b) list  ('a × 'b::zero) list"
where
  "update_by_pair (k, v) [] = (if v = 0 then [] else [(k, v)])"
| "update_by_pair (k, v) ((k', v') # xs) =
  (case comp k k' of Lt  (if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
                     | Eq  (if v = 0 then xs else (k, v) # xs)
                   | Gt  (k', v') # update_by_pair (k, v) xs)"

(* TODO: Add update_by_gr_pair. *)

definition sort_oalist :: "('a × 'b) list  ('a × 'b::zero) list"
  where "sort_oalist xs = foldr update_by_pair xs []"

fun update_by_fun_pair :: "'a  ('b  'b)  ('a × 'b) list  ('a × 'b::zero) list"
where
  "update_by_fun_pair k f [] = (let v = f 0 in if v = 0 then [] else [(k, v)])"
| "update_by_fun_pair k f ((k', v') # xs) =
  (case comp k k' of Lt  (let v = f 0 in if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
                     | Eq  (let v = f v' in if v = 0 then xs else (k, v) # xs)
                   | Gt  (k', v') # update_by_fun_pair k f xs)"

definition update_by_fun_gr_pair :: "'a  ('b  'b)  ('a × 'b) list  ('a × 'b::zero) list"
  where "update_by_fun_gr_pair k f xs =
          (if xs = [] then
            (let v = f 0 in if v = 0 then [] else [(k, v)])
          else if comp k (fst (last xs)) = Gt then
            (let v = f 0 in if v = 0 then xs else xs @ [(k, v)])
          else
            update_by_fun_pair k f xs
          )"

fun (in -) map_pair :: "(('a × 'b)  ('a × 'c))  ('a × 'b::zero) list  ('a × 'c::zero) list"
where
  "map_pair f [] = []"
| "map_pair f (kv # xs) =
    (let (k, v) = f kv; aux = map_pair f xs in if v = 0 then aux else (k, v) # aux)"

text ‹The difference between @{const List.map} and @{const map_pair} is that the latter removes
  @{term 0} values, whereas the former does not.›

abbreviation (in -) map_val_pair :: "('a  'b  'c)  ('a × 'b::zero) list  ('a × 'c::zero) list"
  where "map_val_pair f  map_pair (λ(k, v). (k, f k v))"

fun map2_val_pair :: "('a  'b  'c  'd)  (('a × 'b) list  ('a × 'd) list) 
                      (('a × 'c) list  ('a × 'd) list) 
                      ('a × 'b::zero) list  ('a × 'c::zero) list  ('a × 'd::zero) list"
where
  "map2_val_pair f g h xs [] = g xs"
| "map2_val_pair f g h [] ys = h ys"
| "map2_val_pair f g h ((kx, vx) # xs) ((ky, vy) # ys) =
    (case comp kx ky of
             Lt     (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys) in if v = 0 then aux else (kx, v) # aux)
           | Eq    (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
           | Gt  (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys in if v = 0 then aux else (ky, v) # aux))"

fun lex_ord_pair :: "('a  (('b, 'c) comp_opt))  (('a × 'b::zero) list, ('a × 'c::zero) list) comp_opt"
where
  "lex_ord_pair f []       []       = Some Eq"|
  "lex_ord_pair f []       ((ky, vy) # ys) =
    (let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f [] ys else aux)"|
  "lex_ord_pair f ((kx, vx) # xs) []       =
    (let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs [] else aux)"|
  "lex_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
    (case comp kx ky of
             Lt     (let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs ((ky, vy) # ys) else aux)
           | Eq    (let aux = f kx vx vy in if aux = Some Eq then lex_ord_pair f xs ys else aux)
           | Gt  (let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f ((kx, vx) # xs) ys else aux))"

fun prod_ord_pair :: "('a  'b  'c  bool)  ('a × 'b::zero) list  ('a × 'c::zero) list  bool"
where
  "prod_ord_pair f []       []       = True"|
  "prod_ord_pair f []       ((ky, vy) # ys) = (f ky 0 vy  prod_ord_pair f [] ys)"|
  "prod_ord_pair f ((kx, vx) # xs) []       = (f kx vx 0  prod_ord_pair f xs [])"|
  "prod_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
    (case comp kx ky of
             Lt     (f kx vx 0  prod_ord_pair f xs ((ky, vy) # ys))
           | Eq    (f kx vx vy  prod_ord_pair f xs ys)
           | Gt  (f ky 0 vy  prod_ord_pair f ((kx, vx) # xs) ys))"

text @{const prod_ord_pair} is actually just a special case of @{const lex_ord_pair}, as proved below
  in lemma prod_ord_pair_eq_lex_ord_pair›.›

subsubsection @{const lookup_pair}

lemma lookup_pair_eq_0:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair xs k = 0  (k  fst ` set xs)"
  using assms
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by simp
next
  case (Cons k' v' xs)
  show ?case
  proof (simp add: Cons(3) eq split: order.splits, rule, simp_all only: atomize_imp[symmetric])
    assume "comp k k' = Lt"
    hence "k  k'" by auto
    moreover have "k  fst ` set xs"
    proof
      assume "k  fst ` set xs"
      hence "lt k' k" by (rule Cons(4))
      with comp k k' = Lt› show False by (simp add: Lt_lt_conv)
    qed
    ultimately show "k  k'  k  fst ` set xs" ..
  next
    assume "comp k k' = Gt"
    hence "k  k'" by auto
    thus "(lookup_pair xs k = 0) = (k  k'  k  fst ` set xs)" by (simp add: Cons(5))
  qed
qed

lemma lookup_pair_eq_value:
  assumes "oalist_inv_raw xs" and "v  0"
  shows "lookup_pair xs k = v  ((k, v)  set xs)"
  using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  from assms(2) show ?case by simp
next
  case (Cons k' v' xs)
  have *: "(k', u)  set xs" for u
  proof
    assume "(k', u)  set xs"
    hence "fst (k', u)  fst ` set xs" by fastforce
    hence "k'  fst ` set xs" by simp
    hence "lt k' k'" by (rule Cons(4))
    thus False by (simp add: lt_of_key_order_alt[symmetric])
  qed
  show ?case
  proof (simp add: assms(2) Cons(5) eq split: order.split, intro conjI impI)
    assume "comp k k' = Lt"
    show "(k, v)  set xs"
    proof
      assume "(k, v)  set xs"
      hence "fst (k, v)  fst ` set xs" by fastforce
      hence "k  fst ` set xs" by simp
      hence "lt k' k" by (rule Cons(4))
      with comp k k' = Lt› show False by (simp add: Lt_lt_conv)
    qed
  qed (auto simp: *)
qed

lemma lookup_pair_eq_valueI:
  assumes "oalist_inv_raw xs" and "(k, v)  set xs"
  shows "lookup_pair xs k = v"
proof -
  from assms(2) have "v  snd ` set xs" by force
  moreover from assms(1) have "0  snd ` set xs" by (rule oalist_inv_rawD1)
  ultimately have "v  0" by blast
  with assms show ?thesis by (simp add: lookup_pair_eq_value)
qed

lemma lookup_dflt_eq_lookup_pair:
  assumes "oalist_inv_raw xs"
  shows "lookup_dflt xs = lookup_pair xs"
proof (rule, simp add: lookup_dflt_def split: option.split, intro conjI impI allI)
  fix k
  assume "map_of xs k = None"
  with assms show "lookup_pair xs k = 0" by (simp add: lookup_pair_eq_0 map_of_eq_None_iff)
next
  fix k v
  assume "map_of xs k = Some v"
  hence "(k, v)  set xs" by (rule map_of_SomeD)
  with assms have "lookup_pair xs k = v" by (rule lookup_pair_eq_valueI)
  thus "v = lookup_pair xs k" by (rule HOL.sym)
qed

lemma lookup_pair_inj:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lookup_pair xs = lookup_pair ys"
  shows "xs = ys"
  using assms
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
  case Nil
  thus ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    show ?case by simp
  next
    case (Cons k' v' ys)
    have "v' = lookup_pair ((k', v') # ys) k'" by simp
    also have "... = lookup_pair [] k'" by (simp only: Cons(6))
    also have "... = 0" by simp
    finally have "v' = 0" .
    with Cons(3) show ?case ..
  qed
next
  case *: (Cons k v xs)
  from *(6, 7) show ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    have "v = lookup_pair ((k, v) # xs) k" by simp
    also have "... = lookup_pair [] k" by (simp only: Nil)
    also have "... = 0" by simp
    finally have "v = 0" .
    with *(3) show ?case ..
  next
    case (Cons k' v' ys)
    show ?case
    proof (cases "comp k k'")
      case Lt
      hence "¬ lt k' k" by (simp add: Lt_lt_conv)
      with Cons(4) have "k  fst ` set ys" by blast
      moreover from Lt have "k  k'" by auto
      ultimately have "k  fst ` set ((k', v') # ys)" by simp
      hence "0 = lookup_pair ((k', v') # ys) k"
        by (simp add: lookup_pair_eq_0[OF Cons(1)] del: lookup_pair.simps)
      also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6))
      also have "... = v" by simp
      finally have "v = 0" by simp
      with *(3) show ?thesis ..
    next
      case Eq
      hence "k' = k" by (simp only: eq)
      have "v' = lookup_pair ((k', v') # ys) k'" by simp
      also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6) k' = k)
      also have "... = v" by simp
      finally have "v' = v" .
      moreover note k' = k
      moreover from Cons(2) have "xs = ys"
      proof (rule *(5))
        show "lookup_pair xs = lookup_pair ys"
        proof
          fix k0
          show "lookup_pair xs k0 = lookup_pair ys k0"
          proof (cases "lt k k0")
            case True
            hence eq: "comp k0 k = Gt"
              by (simp add: Gt_lt_conv)
            have "lookup_pair xs k0 = lookup_pair ((k, v) # xs) k0" by (simp add: eq)
            also have "... = lookup_pair ((k, v') # ys) k0" by (simp only: Cons(6) k' = k)
            also have "... = lookup_pair ys k0" by (simp add: eq)
            finally show ?thesis .
          next
            case False
            with *(4) have "k0  fst ` set xs" by blast
            with *(2) have eq: "lookup_pair xs k0 = 0" by (simp add: lookup_pair_eq_0)
            from False Cons(4) have "k0  fst ` set ys" unfolding k' = k by blast
            with Cons(2) have "lookup_pair ys k0 = 0" by (simp add: lookup_pair_eq_0)
            with eq show ?thesis by simp
          qed
        qed
      qed
      ultimately show ?thesis by simp
    next
      case Gt
      hence "¬ lt k k'" by (simp add: Gt_lt_conv)
      with *(4) have "k'  fst ` set xs" by blast
      moreover from Gt have "k'  k" by auto
      ultimately have "k'  fst ` set ((k, v) # xs)" by simp
      hence "0 = lookup_pair ((k, v) # xs) k'"
        by (simp add: lookup_pair_eq_0[OF *(1)] del: lookup_pair.simps)
      also have "... = lookup_pair ((k', v') # ys) k'" by (simp only: Cons(6))
      also have "... = v'" by simp
      finally have "v' = 0" by simp
      with Cons(3) show ?thesis ..
    qed
  qed
qed

lemma lookup_pair_tl:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (tl xs) k = (if (k'fst ` set xs. le k k') then 0 else lookup_pair xs k)"
proof -
  from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
  show ?thesis
  proof (split if_split, intro conjI impI)
    assume *: "xfst ` set xs. le k x"
    show "lookup_pair (tl xs) k = 0"
    proof (simp add: lookup_pair_eq_0[OF 1], rule)
      assume k_in: "k  fst ` set (tl xs)"
      hence "xs  []" by auto
      then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
      have "k'  fst ` set xs" unfolding xs by fastforce
      with * have "le k k'" ..
      from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
      moreover from k_in have "k  fst ` set ys" by (simp add: xs)
      ultimately have "lt k' k" by (rule oalist_inv_raw_ConsD3)
      with ‹le k k' show False by simp
    qed
  next
    assume "¬ (k'fst ` set xs. le k k')"
    hence "xfst ` set xs. ¬ le k x" by simp
    then obtain k'' where k''_in: "k''  fst ` set xs" and "¬ le k k''" ..
    from this(2) have "lt k'' k" by simp
    from k''_in have "xs  []" by auto
    then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
    from k''_in have "k'' = k'  k''  fst ` set ys" by (simp add: xs)
    hence "lt k' k"
    proof
      assume "k'' = k'"
      with ‹lt k'' k show ?thesis by simp
    next
      from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
      moreover assume "k''  fst ` set ys"
      ultimately have "lt k' k''" by (rule oalist_inv_raw_ConsD3)
      thus ?thesis using ‹lt k'' k by (rule less_trans)
    qed
    hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
    thus "lookup_pair (tl xs) k = lookup_pair xs k" by (simp add: xs lt_of_key_order_alt)
  qed
qed

lemma lookup_pair_tl':
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (tl xs) k = (if k = fst (hd xs) then 0 else lookup_pair xs k)"
proof -
  from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
  show ?thesis
  proof (split if_split, intro conjI impI)
    assume k: "k = fst (hd xs)"
    show "lookup_pair (tl xs) k = 0"
    proof (simp add: lookup_pair_eq_0[OF 1], rule)
      assume k_in: "k  fst ` set (tl xs)"
      hence "xs  []" by auto
      then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
      from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
      moreover from k_in have "k'  fst ` set ys" by (simp add: k xs)
      ultimately have "lt k' k'" by (rule oalist_inv_raw_ConsD3)
      thus False by simp
    qed
  next
    assume "k  fst (hd xs)"
    show "lookup_pair (tl xs) k = lookup_pair xs k"
    proof (cases "xs = []")
      case True
      show ?thesis by (simp add: True)
    next
      case False
      then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
      show ?thesis
      proof (simp add: xs eq Lt_lt_conv split: order.split, intro conjI impI)
        from k  fst (hd xs) have "k  k'" by (simp add: xs)
        moreover assume "k = k'"
        ultimately show "lookup_pair ys k' = v'" ..
      next
        assume "lt k k'"
        from assms have "oalist_inv_raw ys" unfolding xs by (rule oalist_inv_raw_ConsD1)
        moreover have "k  fst ` set ys"
        proof
          assume "k  fst ` set ys"
          with assms have "lt k' k" unfolding xs by (rule oalist_inv_raw_ConsD3)
          with ‹lt k k' show False by simp
        qed
        ultimately show "lookup_pair ys k = 0" by (simp add: lookup_pair_eq_0)
      qed
    qed
  qed
qed

lemma lookup_pair_filter:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (filter P xs) k = (let v = lookup_pair xs k in if P (k, v) then v else 0)"
  using assms
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by simp
next
  case (Cons k' v' xs)
  show ?case
  proof (simp add: Cons(5) Let_def eq split: order.split, intro conjI impI)
    show "lookup_pair xs k' = 0"
    proof (simp add: lookup_pair_eq_0 Cons(2), rule)
      assume "k'  fst ` set xs"
      hence "lt k' k'" by (rule Cons(4))
      thus False by simp
    qed
  next
    assume "comp k k' = Lt"
    hence "lt k k'" by (simp only: Lt_lt_conv)
    show "lookup_pair xs k = 0"
    proof (simp add: lookup_pair_eq_0 Cons(2), rule)
      assume "k  fst ` set xs"
      hence "lt k' k" by (rule Cons(4))
      with ‹lt k k' show False by simp
    qed
  qed
qed

lemma lookup_pair_map:
  assumes "oalist_inv_raw xs"
    and "k'. snd (f (k', 0)) = 0"
    and "a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
  shows "lookup_pair (map f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
  using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by (simp add: assms(2))
next
  case (Cons k' v' xs)
  obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
  have "comp k k' = comp (fst (f (k, v))) (fst (f (k', v')))"
    by (simp add: assms(3))
  also have "... = comp (fst (f (k, v))) k''" by (simp add: f)
  finally have eq0: "comp k k' = comp (fst (f (k, v))) k''" .
  show ?case
  proof (simp add: assms(2) split: order.split, intro conjI impI, simp add: eq)
    assume "k = k'"
    hence "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) =
            lookup_pair (f (k', v') # map f xs) (fst (f (k, v)))" by simp
    also have "... = snd (f (k', v'))" by (simp add: f eq0[symmetric], simp add: k = k')
    finally show "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) = snd (f (k', v'))" .
  qed (simp_all add: f eq0 Cons(5))
qed

lemma lookup_pair_Cons:
  assumes "oalist_inv_raw ((k, v) # xs)"
  shows "lookup_pair ((k, v) # xs) k0 = (if k = k0 then v else lookup_pair xs k0)"
proof (simp add: eq split: order.split, intro impI)
  assume "comp k0 k = Lt"
  from assms have inv: "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
  show "lookup_pair xs k0 = 0"
  proof (simp only: lookup_pair_eq_0[OF inv], rule)
    assume "k0  fst ` set xs"
    with assms have "lt k k0" by (rule oalist_inv_raw_ConsD3)
    with comp k0 k = Lt› show False by (simp add: Lt_lt_conv)
  qed
qed

lemma lookup_pair_single: "lookup_pair [(k, v)] k0 = (if k = k0 then v else 0)"
  by (simp add: eq split: order.split)

subsubsection @{const update_by_pair}

lemma set_update_by_pair_subset: "set (update_by_pair kv xs)  insert kv (set xs)"
proof (induct xs arbitrary: kv)
  case Nil
  obtain k v where kv: "kv = (k, v)" by fastforce
  thus ?case by simp
next
  case (Cons x xs)
  obtain k' v' where x: "x = (k', v')" by fastforce
  obtain k v where kv: "kv = (k, v)" by fastforce
  have 1: "set xs  insert a (insert b (set xs))" for a b by auto
  have 2: "set (update_by_pair kv xs)  insert kv (insert (k', v') (set xs))" for kv
    using Cons by blast
  show ?case by (simp add: x kv 1 2 split: order.split)
qed

lemma update_by_pair_sorted:
  assumes "sorted_wrt lt (map fst xs)"
  shows "sorted_wrt lt (map fst (update_by_pair kv xs))"
  using assms
proof (induct xs arbitrary: kv)
  case Nil
  obtain k v where kv: "kv = (k, v)" by fastforce
  thus ?case by simp
next
  case (Cons x xs)
  obtain k' v' where x: "x = (k', v')" by fastforce
  obtain k v where kv: "kv = (k, v)" by fastforce
  from Cons(2) have 1: "sorted_wrt lt (k' # (map fst xs))" by (simp add: x)
  hence 2: "sorted_wrt lt (map fst xs)" using sorted_wrt.elims(3) by fastforce
  hence 3: "sorted_wrt lt (map fst (update_by_pair (k, u) xs))" for u by (rule Cons(1))
  have 4: "sorted_wrt lt (k' # map fst (update_by_pair (k, u) xs))"
    if *: "comp k k' = Gt" for u
  proof (simp, intro conjI ballI)
    fix y
    assume "y  set (update_by_pair (k, u) xs)"
    also from set_update_by_pair_subset have "...  insert (k, u) (set xs)" .
    finally have "y = (k, u)  y  set xs" by simp
    thus "lt k' (fst y)"
    proof
      assume "y = (k, u)"
      hence "fst y = k" by simp
      with * show ?thesis by (simp only: Gt_lt_conv)
    next
      from 1 have 5: "y  fst ` set xs. lt k' y" by simp
      assume "y  set xs"
      hence "fst y  fst ` set xs" by simp
      with 5 show ?thesis ..
    qed
  qed (fact 3)
  show ?case
    by (simp add: kv x 1 2 4 sorted_wrt2 split: order.split del: sorted_wrt.simps,
        intro conjI impI, simp add: 1 eq del: sorted_wrt.simps, simp add: Lt_lt_conv)
qed

lemma update_by_pair_not_0:
  assumes "0  snd ` set xs"
  shows "0  snd ` set (update_by_pair kv xs)"
  using assms
proof (induct xs arbitrary: kv)
  case Nil
  obtain k v where kv: "kv = (k, v)" by fastforce
  thus ?case by simp
next
  case (Cons x xs)
  obtain k' v' where x: "x = (k', v')" by fastforce
  obtain k v where kv: "kv = (k, v)" by fastforce
  from Cons(2) have 1: "v'  0" and 2: "0  snd ` set xs" by (auto simp: x)
  from 2 have 3: "0  snd ` set (update_by_pair (k, u) xs)" for u by (rule Cons(1))
  show ?case by (auto simp: kv x 1 2 3 split: order.split)
qed

corollary oalist_inv_raw_update_by_pair:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (update_by_pair kv xs)"
proof (rule oalist_inv_rawI)
  from assms have "0  snd ` set xs" by (rule oalist_inv_rawD1)
  thus "0  snd ` set (update_by_pair kv xs)" by (rule update_by_pair_not_0)
next
  from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
  thus "sorted_wrt lt (map fst (update_by_pair kv xs))" by (rule update_by_pair_sorted)
qed

lemma update_by_pair_less:
  assumes "v  0" and "xs = []  comp k (fst (hd xs)) = Lt"
  shows "update_by_pair (k, v) xs = (k, v) # xs"
  using assms(2)
proof (induct xs)
case Nil
  from assms(1) show ?case by simp
next
  case (Cons x xs)
  obtain k' v' where x: "x = (k', v')" by fastforce
  from Cons(2) have "comp k k' = Lt" by (simp add: x)
  with assms(1) show ?case by (simp add: x)
qed

lemma lookup_pair_update_by_pair:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (update_by_pair (k1, v) xs) k2 = (if k1 = k2 then v else lookup_pair xs k2)"
  using assms
proof (induct xs arbitrary: v rule: oalist_inv_raw_induct)
  case Nil
  show ?case by (simp split: order.split, simp add: eq)
next
  case (Cons k' v' xs)
  show ?case
  proof (split if_split, intro conjI impI)
    assume "k1 = k2"
    with Cons(5) have eq0: "lookup_pair (update_by_pair (k2, u) xs) k2 = u" for u
      by (simp del: update_by_pair.simps)
    show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = v"
    proof (simp add: k1 = k2 eq0 split: order.split, intro conjI impI)
      assume "comp k2 k' = Eq"
      hence "¬ lt k' k2" by (simp add: eq)
      with Cons(4) have "k2  fst ` set xs" by auto
      thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
    qed
  next
    assume "k1  k2"
    with Cons(5) have eq0: "lookup_pair (update_by_pair (k1, u) xs) k2 = lookup_pair xs k2" for u
      by (simp del: update_by_pair.simps)
    have *: "lookup_pair xs k2 = 0" if "lt k2 k'"
    proof -
      from ‹lt k2 k' have "¬ lt k' k2" by auto
      with Cons(4) have "k2  fst ` set xs" by auto
      thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
    qed
    show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = lookup_pair ((k', v') # xs) k2"
      by (simp add: k1  k2 eq0 split: order.split,
          auto intro: * simp: k1  k2[symmetric] eq Gt_lt_conv Lt_lt_conv)
  qed
qed

corollary update_by_pair_id:
  assumes "oalist_inv_raw xs" and "lookup_pair xs k = v"
  shows "update_by_pair (k, v) xs = xs"
proof (rule lookup_pair_inj, rule oalist_inv_raw_update_by_pair)
  show "lookup_pair (update_by_pair (k, v) xs) = lookup_pair xs"
  proof
    fix k0
    from assms(2) show "lookup_pair (update_by_pair (k, v) xs) k0 = lookup_pair xs k0"
      by (auto simp: lookup_pair_update_by_pair[OF assms(1)])
  qed
qed fact+

lemma set_update_by_pair:
  assumes "oalist_inv_raw xs" and "v  0"
  shows "set (update_by_pair (k, v) xs) = insert (k, v) (set xs - range (Pair k))" (is "?A = ?B")
proof (rule set_eqI)
  fix x::"'a × 'b"
  obtain k' v' where x: "x = (k', v')" by fastforce
  from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, v) xs)"
    by (rule oalist_inv_raw_update_by_pair)
  show "(x  ?A)  (x  ?B)"
  proof (cases "v' = 0")
    case True
    have "0  snd ` set (update_by_pair (k, v) xs)" and "0  snd ` set xs"
      by (rule oalist_inv_rawD1, fact)+
    hence "(k', 0)  set (update_by_pair (k, v) xs)" and "(k', 0)  set xs"
      using image_iff by fastforce+
    thus ?thesis by (simp add: x True assms(2))
  next
    case False
    show ?thesis
      by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms(1) False]
          lookup_pair_update_by_pair[OF assms(1)])
  qed
qed

lemma set_update_by_pair_zero:
  assumes "oalist_inv_raw xs"
  shows "set (update_by_pair (k, 0) xs) = set xs - range (Pair k)" (is "?A = ?B")
proof (rule set_eqI)
  fix x::"'a × 'b"
  obtain k' v' where x: "x = (k', v')" by fastforce
  from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, 0) xs)"
    by (rule oalist_inv_raw_update_by_pair)
  show "(x  ?A)  (x  ?B)"
  proof (cases "v' = 0")
    case True
    have "0  snd ` set (update_by_pair (k, 0) xs)" and "0  snd ` set xs"
      by (rule oalist_inv_rawD1, fact)+
    hence "(k', 0)  set (update_by_pair (k, 0) xs)" and "(k', 0)  set xs"
      using image_iff by fastforce+
    thus ?thesis by (simp add: x True)
  next
    case False
    show ?thesis
      by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms False]
          lookup_pair_update_by_pair[OF assms] False)
  qed
qed

subsubsection @{const update_by_fun_pair} and @{const update_by_fun_gr_pair}

lemma update_by_fun_pair_eq_update_by_pair:
  assumes "oalist_inv_raw xs"
  shows "update_by_fun_pair k f xs = update_by_pair (k, f (lookup_pair xs k)) xs"
  using assms by (induct xs rule: oalist_inv_raw_induct, simp, simp split: order.split)

corollary oalist_inv_raw_update_by_fun_pair:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (update_by_fun_pair k f xs)"
  unfolding update_by_fun_pair_eq_update_by_pair[OF assms] using assms by (rule oalist_inv_raw_update_by_pair)

corollary lookup_pair_update_by_fun_pair:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (update_by_fun_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
  by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms] lookup_pair_update_by_pair[OF assms])

lemma update_by_fun_pair_gr:
  assumes "oalist_inv_raw xs" and "xs = []  comp k (fst (last xs)) = Gt"
  shows "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
  using assms
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by simp
next
  case (Cons k' v' xs)
  from Cons(6) have 1: "comp k (fst (last ((k', v') # xs))) = Gt" by simp
  have eq1: "comp k k' = Gt"
  proof (cases "xs = []")
    case True
    with 1 show ?thesis by simp
  next
    case False
    have "lt k' (fst (last xs))" by (rule Cons(4), simp add: False)
    from False 1 have "comp k (fst (last xs)) = Gt" by simp
    moreover from ‹lt k' (fst (last xs)) have "comp (fst (last xs)) k' = Gt"
      by (simp add: Gt_lt_conv)
    ultimately show ?thesis
      by (meson Gt_lt_conv less_trans Lt_lt_conv[symmetric])
  qed
  have eq2: "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
  proof (rule Cons(5), simp only: disj_commute[of "xs = []"], rule disjCI)
    assume "xs  []"
    with 1 show "comp k (fst (last xs)) = Gt" by simp
  qed
  show ?case by (simp split: order.split add: Let_def eq1 eq2)
qed

corollary update_by_fun_gr_pair_eq_update_by_fun_pair:
  assumes "oalist_inv_raw xs"
  shows "update_by_fun_gr_pair k f xs = update_by_fun_pair k f xs"
  by (simp add: update_by_fun_gr_pair_def Let_def update_by_fun_pair_gr[OF assms] split: order.split)

corollary oalist_inv_raw_update_by_fun_gr_pair:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (update_by_fun_gr_pair k f xs)"
  unfolding update_by_fun_pair_eq_update_by_pair[OF assms] update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms]
  using assms by (rule oalist_inv_raw_update_by_pair)

corollary lookup_pair_update_by_fun_gr_pair:
  assumes "oalist_inv_raw xs"
  shows "lookup_pair (update_by_fun_gr_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
  by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms]
      update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms] lookup_pair_update_by_pair[OF assms])

subsubsection @{const map_pair}

lemma map_pair_cong:
  assumes "kv. kv  set xs  f kv = g kv"
  shows "map_pair f xs = map_pair g xs"
  using assms
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have "f x = g x" by (rule Cons(2), simp)
  moreover have "map_pair f xs = map_pair g xs" by (rule Cons(1), rule Cons(2), simp)
  ultimately show ?case by simp
qed

lemma map_pair_subset: "set (map_pair f xs)  f ` set xs"
proof (induct xs rule: map_pair.induct)
  case (1 f)
  show ?case by simp
next
  case (2 f kv xs)
  obtain k v where f: "f kv = (k, v)" by fastforce
  from f[symmetric] HOL.refl have *: "set (map_pair f xs)  f ` set xs"
    by (rule 2)
  show ?case by (simp add: f Let_def, intro conjI impI subset_insertI2 *)
qed

lemma oalist_inv_raw_map_pair:
  assumes "oalist_inv_raw xs"
    and "a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
  shows "oalist_inv_raw (map_pair f xs)"
  using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  from oalist_inv_raw_Nil show ?case by simp
next
  case (Cons k v xs)
  obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
  show ?case
  proof (simp add: f Let_def Cons(5), rule)
    assume "v'  0"
    with Cons(5) show "oalist_inv_raw ((k', v') # map_pair f xs)"
    proof (rule oalist_inv_raw_ConsI)
      assume "map_pair f xs  []"
      hence "hd (map_pair f xs)  set (map_pair f xs)" by simp
      also have "...  f ` set xs" by (fact map_pair_subset)
      finally obtain x where "x  set xs" and eq: "hd (map_pair f xs) = f x" ..
      from this(1) have "fst x  fst ` set xs" by fastforce
      hence "lt k (fst x)" by (rule Cons(4))
      hence "lt (fst (f (k, v))) (fst (f x))"
        by (simp add: Lt_lt_conv[symmetric] assms(2))
      thus "lt k' (fst (hd (map_pair f xs)))" by (simp add: f eq)
    qed
  qed
qed

lemma lookup_pair_map_pair:
  assumes "oalist_inv_raw xs" and "snd (f (k, 0)) = 0"
    and "a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
  shows "lookup_pair (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
  using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by (simp add: assms(2))
next
  case (Cons k' v' xs)
  obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
  have "comp (fst (f (k, v))) k'' = comp (fst (f (k, v))) (fst (f (k', v')))"
    by (simp add: f)
  also have "... = comp k k'"
    by (simp add: assms(3))
  finally have eq0: "comp (fst (f (k, v))) k'' = comp k k'" .
  have *: "lookup_pair xs k = 0" if "comp k k'  Gt"
  proof (simp add: lookup_pair_eq_0[OF Cons(2)], rule)
    assume "k  fst ` set xs"
    hence "lt k' k" by (rule Cons(4))
    hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
    with comp k k'  Gt› show False ..
  qed
  show ?case
  proof (simp add: assms(2) f Let_def eq0 Cons(5) split: order.split, intro conjI impI)
    assume "comp k k' = Lt"
    hence "comp k k'  Gt" by simp
    hence "lookup_pair xs k = 0" by (rule *)
    thus "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
  next
    assume "v'' = 0"
    assume "comp k k' = Eq"
    hence "k = k'" and "comp k k'  Gt" by (simp only: eq, simp)
    from this(2) have "lookup_pair xs k = 0" by (rule *)
    hence "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
    also have "... = snd (f (k, v'))" by (simp add: k = k' f v'' = 0)
    finally show "snd (f (k, lookup_pair xs k)) = snd (f (k, v'))" .
  qed (simp add: f eq)
qed

lemma lookup_dflt_map_pair:
  assumes "distinct (map fst xs)" and "snd (f (k, 0)) = 0"
    and "a b. (fst (f a) = fst (f b))  (fst a = fst b)"
  shows "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
  using assms(1)
proof (induct xs)
  case Nil
  show ?case by (simp add: lookup_dflt_def assms(2))
next
  case (Cons x xs)
  obtain k' v' where x: "x = (k', v')" by fastforce
  obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
  from Cons(2) have "distinct (map fst xs)" and "k'  fst ` set xs" by (simp_all add: x)
  from this(1) have eq1: "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
    by (rule Cons(1))
  have eq2: "lookup_dflt ((a, b) # ys) c = (if c = a then b else lookup_dflt ys c)"
    for a b c and ys::"('b × 'e::zero) list" by (simp add: lookup_dflt_def map_of_Cons_code)
  from k'  fst ` set xs have "map_of xs k' = None" by (simp add: map_of_eq_None_iff)
  hence eq3: "lookup_dflt xs k' = 0" by (simp add: lookup_dflt_def)
  show ?case
  proof (simp add: f Let_def x eq1 eq2 eq3, intro conjI impI)
    assume "k = k'"
    hence "snd (f (k', 0)) = snd (f (k, 0))" by simp
    also have "... = 0" by (fact assms(2))
    finally show "snd (f (k', 0)) = 0" .
  next
    assume "fst (f (k', v))  k''"
    hence "fst (f (k', v))  fst (f (k', v'))" by (simp add: f)
    thus "snd (f (k', 0)) = v''" by (simp add: assms(3))
  next
    assume "k  k'"
    assume "fst (f (k, v)) = k''"
    also have "... = fst (f (k', v'))" by (simp add: f)
    finally have "k = k'" by (simp add: assms(3))
    with k  k' show "v'' = snd (f (k, lookup_dflt xs k))" ..
  qed
qed

lemma distinct_map_pair:
  assumes "distinct (map fst xs)" and "a b. fst (f a) = fst (f b)  fst a = fst b"
  shows "distinct (map fst (map_pair f xs))"
  using assms(1)
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  obtain k v where x: "x = (k, v)" by fastforce
  obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
  from Cons(2) have "distinct (map fst xs)" and "k  fst ` set xs" by (simp_all add: x)
  from this(1) have 1: "distinct (map fst (map_pair f xs))" by (rule Cons(1))
  show ?case
  proof (simp add: x f Let_def 1, intro impI notI)
    assume "v'  0"
    assume "k'  fst ` set (map_pair f xs)"
    then obtain y where "y  set (map_pair f xs)" and "k' = fst y" ..
    from this(1) map_pair_subset have "y  f ` set xs" ..
    then obtain z where "z  set xs" and "y = f z" ..
    from this(2) have "fst (f z) = k'" by (simp add: k' = fst y)
    also have "... = fst (f (k, v))" by (simp add: f)
    finally have "fst z = fst (k, v)" by (rule assms(2))
    also have "... = k" by simp
    finally have "k  fst ` set xs" using z  set xs by blast
    with k  fst ` set xs show False ..
  qed
qed

lemma map_val_pair_cong:
  assumes "k v. (k, v)  set xs  f k v = g k v"
  shows "map_val_pair f xs = map_val_pair g xs"
proof (rule map_pair_cong)
  fix kv
  assume "kv  set xs"
  moreover obtain k v where "kv = (k, v)" by fastforce
  ultimately show "(case kv of (k, v)  (k, f k v)) = (case kv of (k, v)  (k, g k v))"
    by (simp add: assms)
qed

lemma oalist_inv_raw_map_val_pair:
  assumes "oalist_inv_raw xs"
  shows "oalist_inv_raw (map_val_pair f xs)"
  by (rule oalist_inv_raw_map_pair, fact assms, auto)

lemma lookup_pair_map_val_pair:
  assumes "oalist_inv_raw xs" and "f k 0 = 0"
  shows "lookup_pair (map_val_pair f xs) k = f k (lookup_pair xs k)"
proof -
  let ?f = "λ(k', v'). (k', f k' v')"
  have "lookup_pair (map_val_pair f xs) k = lookup_pair (map_val_pair f xs) (fst (?f (k, 0)))"
    by simp
  also have "... = snd (?f (k, local.lookup_pair xs k))"
    by (rule lookup_pair_map_pair, fact assms(1), auto simp: assms(2))
  also have "... = f k (lookup_pair xs k)" by simp
  finally show ?thesis .
qed

lemma map_pair_id:
  assumes "oalist_inv_raw xs"
  shows "map_pair id xs = xs"
  using assms
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by simp
next
  case (Cons k v xs')
  show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
qed

subsubsection @{const map2_val_pair}

definition map2_val_compat :: "(('a × 'b::zero) list  ('a × 'c::zero) list)  bool"
  where "map2_val_compat f  (zs. (oalist_inv_raw zs 
                                (oalist_inv_raw (f zs)  fst ` set (f zs)  fst ` set zs)))"

lemma map2_val_compatI:
  assumes "zs. oalist_inv_raw zs  oalist_inv_raw (f zs)"
    and "zs. oalist_inv_raw zs  fst ` set (f zs)  fst ` set zs"
  shows "map2_val_compat f"
  unfolding map2_val_compat_def using assms by blast

lemma map2_val_compatD1:
  assumes "map2_val_compat f" and "oalist_inv_raw zs"
  shows "oalist_inv_raw (f zs)"
  using assms unfolding map2_val_compat_def by blast

lemma map2_val_compatD2:
  assumes "map2_val_compat f" and "oalist_inv_raw zs"
  shows "fst ` set (f zs)  fst ` set zs"
  using assms unfolding map2_val_compat_def by blast

lemma map2_val_compat_Nil:
  assumes "map2_val_compat (f::('a × 'b::zero) list  ('a × 'c::zero) list)"
  shows "f [] = []"
proof -
  from assms oalist_inv_raw_Nil have "fst ` set (f [])  fst ` set ([]::('a × 'b) list)"
    by (rule map2_val_compatD2)
  thus ?thesis by simp
qed

lemma map2_val_compat_id: "map2_val_compat id"
  by (rule map2_val_compatI, auto)

lemma map2_val_compat_map_val_pair: "map2_val_compat (map_val_pair f)"
proof (rule map2_val_compatI, erule oalist_inv_raw_map_val_pair)
  fix zs
  from map_pair_subset image_iff show "fst ` set (map_val_pair f zs)  fst ` set zs" by fastforce
qed

lemma fst_map2_val_pair_subset:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
  assumes "map2_val_compat g" and "map2_val_compat h"
  shows "fst ` set (map2_val_pair f g h xs ys)  fst ` set xs  fst ` set ys"
  using assms
proof (induct f g h xs ys rule: map2_val_pair.induct)
  case (1 f g h xs)
  show ?case by (simp, rule map2_val_compatD2, fact+)
next
  case (2 f g h v va)
  show ?case by (simp del: set_simps(2), rule map2_val_compatD2, fact+)
next
  case (3 f g h kx vx xs ky vy ys)
  from 3(4) have "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
  from 3(5) have "oalist_inv_raw ys" by (rule oalist_inv_raw_ConsD1)
  show ?case
  proof (simp split: order.split, intro conjI impI)
    assume "comp kx ky = Lt"
    hence "fst ` set (map2_val_pair f g h xs ((ky, vy) # ys))  fst ` set xs  fst ` set ((ky, vy) # ys)"
      using HOL.refl ‹oalist_inv_raw xs 3(5, 6, 7) by (rule 3(2))
    thus "fst ` set (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys)
                       in if v = 0 then aux else (kx, v) # aux)
           insert ky (insert kx (fst ` set xs  fst ` set ys))" by (auto simp: Let_def)
  next
    assume "comp kx ky = Eq"
    hence "fst ` set (map2_val_pair f g h xs ys)  fst ` set xs  fst ` set ys"
      using HOL.refl ‹oalist_inv_raw xs ‹oalist_inv_raw ys 3(6, 7) by (rule 3(1))
    thus "fst ` set (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
           insert ky (insert kx (fst ` set xs  fst ` set ys))" by (auto simp: Let_def)
  next
    assume "comp kx ky = Gt"
    hence "fst ` set (map2_val_pair f g h ((kx, vx) # xs) ys)  fst ` set ((kx, vx) # xs)  fst ` set ys"
      using HOL.refl 3(4) ‹oalist_inv_raw ys 3(6, 7) by (rule 3(3))
    thus "fst ` set (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys
                        in if v = 0 then aux else (ky, v) # aux)
           insert ky (insert kx (fst ` set xs  fst ` set ys))" by (auto simp: Let_def)
  qed
qed

lemma oalist_inv_raw_map2_val_pair:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
  assumes "map2_val_compat g" and "map2_val_compat h"
  shows "oalist_inv_raw (map2_val_pair f g h xs ys)"
  using assms(1, 2)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
  case Nil
  show ?case
  proof (cases ys)
    case Nil
    show ?thesis by (simp add: Nil, rule map2_val_compatD1, fact assms(3), fact oalist_inv_raw_Nil)
  next
    case (Cons y ys')
    show ?thesis by (simp add: Cons, rule map2_val_compatD1, fact assms(4), simp only: Cons[symmetric], fact Nil)
  qed
next
  case *: (Cons k v xs)
  from *(6) show ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    show ?case by (simp, rule map2_val_compatD1, fact assms(3), fact *(1))
  next
    case (Cons k' v' ys)
    show ?case
    proof (simp split: order.split, intro conjI impI)
      assume "comp k k' = Lt"
      hence 0: "lt k k'" by (simp only: Lt_lt_conv)
      from Cons(1) have 1: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))" by (rule *(5))
      show "oalist_inv_raw (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
              in if v = 0 then aux else (k, v) # aux)"
      proof (simp add: Let_def, intro conjI impI)
        assume "f k v 0  0"
        with 1 show "oalist_inv_raw ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys))"
        proof (rule oalist_inv_raw_ConsI)
          define k0 where "k0 = fst (hd (local.map2_val_pair f g h xs ((k', v') # ys)))"
          assume "map2_val_pair f g h xs ((k', v') # ys)  []"
          hence "k0  fst ` set (map2_val_pair f g h xs ((k', v') # ys))" by (simp add: k0_def)
          also from *(2) Cons(1) assms(3, 4) have "...  fst ` set xs  fst ` set ((k', v') # ys)"
            by (rule fst_map2_val_pair_subset)
          finally have "k0  fst ` set xs  k0 = k'  k0  fst ` set ys" by auto
          thus "lt k k0"
          proof (elim disjE)
            assume "k0 = k'"
            with 0 show ?thesis by simp
          next
            assume "k0  fst ` set ys"
            hence "lt k' k0" by (rule Cons(4))
            with 0 show ?thesis by (rule less_trans)
          qed (rule *(4))
        qed
      qed (rule 1)
    next
      assume "comp k k' = Eq"
      hence "k = k'" by (simp only: eq)
      from Cons(2) have 1: "oalist_inv_raw (map2_val_pair f g h xs ys)" by (rule *(5))
      show "oalist_inv_raw (let v = f k v v'; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (k, v) # aux)"
      proof (simp add: Let_def, intro conjI impI)
        assume "f k v v'  0"
        with 1 show "oalist_inv_raw ((k, f k v v') # map2_val_pair f g h xs ys)"
        proof (rule oalist_inv_raw_ConsI)
          define k0 where "k0 = fst (hd (map2_val_pair f g h xs ys))"
          assume "map2_val_pair f g h xs ys  []"
          hence "k0  fst ` set (map2_val_pair f g h xs ys)" by (simp add: k0_def)
          also from *(2) Cons(2) assms(3, 4) have "...  fst ` set xs  fst ` set ys"
            by (rule fst_map2_val_pair_subset)
          finally show "lt k k0"
          proof
            assume "k0  fst ` set ys"
            hence "lt k' k0" by (rule Cons(4))
            thus ?thesis by (simp only: k = k')
          qed (rule *(4))
        qed
      qed (rule 1)
    next
      assume "comp k k' = Gt"
      hence 0: "lt k' k" by (simp only: Gt_lt_conv)
      show "oalist_inv_raw (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
              in if va = 0 then aux else (k', va) # aux)"
      proof (simp add: Let_def, intro conjI impI)
        assume "f k' 0 v'  0"
        with Cons(5) show "oalist_inv_raw ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys)"
        proof (rule oalist_inv_raw_ConsI)
          define k0 where "k0 = fst (hd (map2_val_pair f g h ((k, v) # xs) ys))"
          assume "map2_val_pair f g h ((k, v) # xs) ys  []"
          hence "k0  fst ` set (map2_val_pair f g h ((k, v) # xs) ys)" by (simp add: k0_def)
          also from *(1) Cons(2) assms(3, 4) have "...  fst ` set ((k, v) # xs)  fst ` set ys"
            by (rule fst_map2_val_pair_subset)
          finally have "k0 = k  k0  fst ` set xs  k0  fst ` set ys" by auto
          thus "lt k' k0"
          proof (elim disjE)
            assume "k0 = k"
            with 0 show ?thesis by simp
          next
            assume "k0  fst ` set xs"
            hence "lt k k0" by (rule *(4))
            with 0 show ?thesis by (rule less_trans)
          qed (rule Cons(4))
        qed
      qed (rule Cons(5))
    qed
  qed
qed

lemma lookup_pair_map2_val_pair:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
  assumes "map2_val_compat g" and "map2_val_compat h"
  assumes "zs. oalist_inv_raw zs  g zs = map_val_pair (λk v. f k v 0) zs"
    and "zs. oalist_inv_raw zs  h zs = map_val_pair (λk. f k 0) zs"
    and "k. f k 0 0 = 0"
  shows "lookup_pair (map2_val_pair f g h xs ys) k0 = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
  using assms(1, 2)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
  case Nil
  show ?case
  proof (cases ys)
    case Nil
    show ?thesis by (simp add: Nil map2_val_compat_Nil[OF assms(3)] assms(7))
  next
    case (Cons y ys')
    then obtain k v ys' where ys: "ys = (k, v) # ys'" by fastforce
    from Nil have "lookup_pair (h ys) k0 = lookup_pair (map_val_pair (λk. f k 0) ys) k0"
      by (simp only: assms(6))
    also have "... = f k0 0 (lookup_pair ys k0)" by (rule lookup_pair_map_val_pair, fact Nil, fact assms(7))
    finally have "lookup_pair (h ((k, v) # ys')) k0 = f k0 0 (lookup_pair ((k, v) # ys') k0)"
      by (simp only: ys)
    thus ?thesis by (simp add: ys)
  qed
next
  case *: (Cons k v xs)
  from *(6) show ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    from *(1) have "lookup_pair (g ((k, v) # xs)) k0 = lookup_pair (map_val_pair (λk v. f k v 0) ((k, v) # xs)) k0"
      by (simp only: assms(5))
    also have "... = f k0 (lookup_pair ((k, v) # xs) k0) 0"
      by (rule lookup_pair_map_val_pair, fact *(1), fact assms(7))
    finally show ?case by simp
  next
    case (Cons k' v' ys)
    show ?case
    proof (cases "comp k0 k = Lt  comp k0 k' = Lt")
      case True
      hence 1: "comp k0 k = Lt" and 2: "comp k0 k' = Lt" by simp_all
      hence eq: "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0) = 0"
        by (simp add: assms(7))
      from *(1) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
        by (rule oalist_inv_raw_map2_val_pair)
      show ?thesis
      proof (simp only: eq lookup_pair_eq_0[OF inv], rule)
        assume "k0  fst ` set (local.map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
        also from *(1) Cons(1) assms(3, 4) have "...  fst ` set ((k, v) # xs)  fst ` set ((k', v') # ys)"
          by (rule fst_map2_val_pair_subset)
        finally have "k0  fst ` set xs  k0  fst ` set ys" using 1 2 by auto
        thus False
        proof
          assume "k0  fst ` set xs"
          hence "lt k k0" by (rule *(4))
          with 1 show ?thesis by (simp add: Lt_lt_conv)
        next
          assume "k0  fst ` set ys"
          hence "lt k' k0" by (rule Cons(4))
          with 2 show ?thesis by (simp add: Lt_lt_conv)
        qed
      qed
    next
      case False
      show ?thesis
      proof (simp split: order.split del: lookup_pair.simps, intro conjI impI)
        assume "comp k k' = Lt"
        with False have "comp k0 k  Lt" by (auto simp: Lt_lt_conv)
        show "lookup_pair (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
                            in if v = 0 then aux else (k, v) # aux) k0 =
              f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
        proof (cases "comp k0 k")
          case Lt
          with comp k0 k  Lt› show ?thesis ..
        next
          case Eq
          hence "k0 = k" by (simp only: eq)
          with comp k k' = Lt› have "comp k0 k' = Lt" by simp
          hence eq1: "lookup_pair ((k', v') # ys) k = 0" by (simp add: k0 = k)
          have eq2: "lookup_pair ((k, v) # xs) k = v" by simp
          show ?thesis
          proof (simp add: Let_def eq1 eq2 k0 = k del: lookup_pair.simps, intro conjI impI)
            from *(2) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))"
              by (rule oalist_inv_raw_map2_val_pair)
            show "lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k = 0"
            proof (simp only: lookup_pair_eq_0[OF inv], rule)
              assume "k  fst ` set (local.map2_val_pair f g h xs ((k', v') # ys))"
              also from *(2) Cons(1) assms(3, 4) have "...  fst ` set xs  fst ` set ((k', v') # ys)"
                by (rule fst_map2_val_pair_subset)
              finally have "k  fst ` set xs  k  fst ` set ys" using comp k k' = Lt›
                by auto
              thus False
              proof
                assume "k  fst ` set xs"
                hence "lt k k" by (rule *(4))
                thus ?thesis by simp
              next
                assume "k  fst ` set ys"
                hence "lt k' k" by (rule Cons(4))
                with comp k k' = Lt› show ?thesis by (simp add: Lt_lt_conv)
              qed
            qed
          qed simp
        next
          case Gt
          hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
            and eq2: "lookup_pair ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys)) k0 =
                  lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k0" by simp_all
          show ?thesis
            by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule *(5), fact Cons(1))
        qed
      next
        assume "comp k k' = Eq"
        hence "k = k'" by (simp only: eq)
        with False have "comp k0 k'  Lt" by (auto simp: Lt_lt_conv)
        show "lookup_pair (let v = f k v v'; aux = map2_val_pair f g h xs ys in
                            if v = 0 then aux else (k, v) # aux) k0 =
              f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
        proof (cases "comp k0 k'")
          case Lt
          with comp k0 k'  Lt› show ?thesis ..
        next
          case Eq
          hence "k0 = k'" by (simp only: eq)
          show ?thesis
          proof (simp add: Let_def k = k' k0 = k', intro impI)
            from *(2) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ys)"
              by (rule oalist_inv_raw_map2_val_pair)
            show "lookup_pair (map2_val_pair f g h xs ys) k' = 0"
            proof (simp only: lookup_pair_eq_0[OF inv], rule)
              assume "k'  fst ` set (map2_val_pair f g h xs ys)"
              also from *(2) Cons(2) assms(3, 4) have "...  fst ` set xs  fst ` set ys"
                by (rule fst_map2_val_pair_subset)
              finally show False
              proof
                assume "k'  fst ` set ys"
                hence "lt k' k'" by (rule Cons(4))
                thus ?thesis by simp
              next
                assume "k'  fst ` set xs"
                hence "lt k k'" by (rule *(4))
                thus ?thesis by (simp add: k = k')
              qed
            qed
          qed
        next
          case Gt
          hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
            and eq2: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
            and eq3: "lookup_pair ((k, f k v v') # map2_val_pair f g h xs ys) k0 =
                  lookup_pair (map2_val_pair f g h xs ys) k0" by (simp_all add: k = k')
          show ?thesis by (simp add: Let_def eq1 eq2 eq3 del: lookup_pair.simps, rule *(5), fact Cons(2))
        qed
      next
        assume "comp k k' = Gt"
        hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
        with False have "comp k0 k'  Lt" by (auto simp: Lt_lt_conv)
        show "lookup_pair (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
                            in if va = 0 then aux else (k', va) # aux) k0 =
              f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
        proof (cases "comp k0 k'")
          case Lt
          with comp k0 k'  Lt› show ?thesis ..
        next
          case Eq
          hence "k0 = k'" by (simp only: eq)
          with comp k' k = Lt› have "comp k0 k = Lt" by simp
          hence eq1: "lookup_pair ((k, v) # xs) k' = 0" by (simp add: k0 = k')
          have eq2: "lookup_pair ((k', v') # ys) k' = v'" by simp
          show ?thesis
          proof (simp add: Let_def eq1 eq2 k0 = k' del: lookup_pair.simps, intro conjI impI)
            from *(1) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ys)"
              by (rule oalist_inv_raw_map2_val_pair)
            show "lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k' = 0"
            proof (simp only: lookup_pair_eq_0[OF inv], rule)
              assume "k'  fst ` set (map2_val_pair f g h ((k, v) # xs) ys)"
              also from *(1) Cons(2) assms(3, 4) have "...  fst ` set ((k, v) # xs)  fst ` set ys"
                by (rule fst_map2_val_pair_subset)
              finally have "k'  fst ` set xs  k'  fst ` set ys" using comp k' k = Lt›
                by auto
              thus False
              proof
                assume "k'  fst ` set ys"
                hence "lt k' k'" by (rule Cons(4))
                thus ?thesis by simp
              next
                assume "k'  fst ` set xs"
                hence "lt k k'" by (rule *(4))
                with comp k' k = Lt› show ?thesis by (simp add: Lt_lt_conv)
              qed
            qed
          qed simp
        next
          case Gt
          hence eq1: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
            and eq2: "lookup_pair ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys) k0 =
                  lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k0" by simp_all
          show ?thesis by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule Cons(5))
        qed
      qed
    qed
  qed
qed

lemma map2_val_pair_singleton_eq_update_by_fun_pair:
  assumes "oalist_inv_raw xs"
  assumes "k x. f k x 0 = x" and "zs. oalist_inv_raw zs  g zs = zs"
    and "h [(k, v)] = map_val_pair (λk. f k 0) [(k, v)]"
  shows "map2_val_pair f g h xs [(k, v)] = update_by_fun_pair k (λx. f k x v) xs"
  using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
  case Nil
  show ?case by (simp add: Let_def assms(4))
next
  case (Cons k' v' xs)
  show ?case
  proof (cases "comp k' k")
    case Lt
    hence gr: "comp k k' = Gt" by (simp only: Gt_lt_conv Lt_lt_conv)
    show ?thesis by (simp add: Lt gr Let_def assms(2) Cons(3, 5))
  next
    case Eq
    hence eq1: "comp k k' = Eq" and eq2: "k = k'" by (simp_all only: eq)
    show ?thesis by (simp add: Eq eq1 eq2 Let_def assms(3)[OF Cons(2)])
  next
    case Gt
    hence less: "comp k k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
    show ?thesis by (simp add: Gt less Let_def assms(3)[OF Cons(1)])
  qed
qed

subsubsection @{const lex_ord_pair}

lemma lex_ord_pair_EqI:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
    and "k. k  fst ` set xs  fst ` set ys  f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
  shows "lex_ord_pair f xs ys = Some Eq"
  using assms
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
  case Nil
  thus ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    show ?case by simp
  next
    case (Cons k v ys)
    show ?case
    proof (simp add: Let_def, intro conjI impI, rule Cons(5))
      fix k0
      assume "k0  fst ` set []  fst ` set ys"
      hence "k0  fst ` set ys" by simp
      hence "lt k k0" by (rule Cons(4))
      hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = f k0 (lookup_pair [] k0) (lookup_pair ((k, v) # ys) k0)"
        by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
      also have "... = Some Eq" by (rule Cons(6), simp add: k0  fst ` set ys)
      finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
    next
      have "f k 0 v = f k (lookup_pair [] k) (lookup_pair ((k, v) # ys) k)" by simp
      also have "... = Some Eq" by (rule Cons(6), simp)
      finally show "f k 0 v = Some Eq" .
    qed
  qed
next
  case *: (Cons k v xs)
  from *(6, 7) show ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    show ?case
    proof (simp add: Let_def, intro conjI impI, rule *(5), rule oalist_inv_raw_Nil)
      fix k0
      assume "k0  fst ` set xs  fst ` set []"
      hence "k0  fst ` set xs" by simp
      hence "lt k k0" by (rule *(4))
      hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair [] k0)"
        by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
      also have "... = Some Eq" by (rule Nil, simp add: k0  fst ` set xs)
      finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
    next
      have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair [] k)" by simp
      also have "... = Some Eq" by (rule Nil, simp)
      finally show "f k v 0 = Some Eq" .
    qed
  next
    case (Cons k' v' ys)
    show ?case
    proof (simp split: order.split, intro conjI impI)
      assume "comp k k' = Lt"
      show "(let aux = f k v 0 in if aux = Some Eq then lex_ord_pair f xs ((k', v') # ys) else aux) = Some Eq"
      proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(1))
        fix k0
        assume k0_in: "k0  fst ` set xs  fst ` set ((k', v') # ys)"
        hence "k0  fst ` set xs  k0 = k'  k0  fst ` set ys" by auto
        hence "k0  k"
        proof (elim disjE)
          assume "k0  fst ` set xs"
          hence "lt k k0" by (rule *(4))
          thus ?thesis by simp
        next
          assume "k0 = k'"
          with comp k k' = Lt› show ?thesis by auto
        next
          assume "k0  fst ` set ys"
          hence "lt k' k0" by (rule Cons(4))
          with comp k k' = Lt› show ?thesis by (simp add: Lt_lt_conv)
        qed
        hence "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) =
                f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
          by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
        also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
        finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) = Some Eq" .
      next
        have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
          by (simp add: comp k k' = Lt›)
        also have "... = Some Eq" by (rule Cons(6), simp)
        finally show "f k v 0 = Some Eq" .
      qed
    next
      assume "comp k k' = Eq"
      hence "k = k'" by (simp only: eq)
      show "(let aux = f k v v' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = Some Eq"
      proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(2))
        fix k0
        assume k0_in: "k0  fst ` set xs  fst ` set ys"
        hence "k0  k'"
        proof
          assume "k0  fst ` set xs"
          hence "lt k k0" by (rule *(4))
          thus ?thesis by (simp add: k = k')
        next
          assume "k0  fst ` set ys"
          hence "lt k' k0" by (rule Cons(4))
          thus ?thesis by simp
        qed
        hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
                f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
          by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
              auto simp: k = k')
        also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
        finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
      next
        have "f k v v' = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
          by (simp add: k = k')
        also have "... = Some Eq" by (rule Cons(6), simp)
        finally show "f k v v' = Some Eq" .
      qed
    next
      assume "comp k k' = Gt"
      hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
      show "(let aux = f k' 0 v' in if aux = Some Eq then lex_ord_pair f ((k, v) # xs) ys else aux) = Some Eq"
      proof (simp add: Let_def, intro conjI impI, rule Cons(5))
        fix k0
        assume k0_in: "k0  fst ` set ((k, v) # xs)  fst ` set ys"
        hence "k0  fst ` set xs  k0 = k  k0  fst ` set ys" by auto
        hence "k0  k'"
        proof (elim disjE)
          assume "k0  fst ` set xs"
          hence "lt k k0" by (rule *(4))
          with comp k' k = Lt› show ?thesis by (simp add: Lt_lt_conv)
        next
          assume "k0 = k"
          with comp k' k = Lt› show ?thesis by auto
        next
          assume "k0  fst ` set ys"
          hence "lt k' k0" by (rule Cons(4))
          thus ?thesis by simp
        qed
        hence "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) =
                f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
          by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
        also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
        finally show "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) = Some Eq" .
      next
        have "f k' 0 v' = f k' (lookup_pair ((k, v) # xs) k') (lookup_pair ((k', v') # ys) k')"
          by (simp add: comp k' k = Lt›)
        also have "... = Some Eq" by (rule Cons(6), simp)
        finally show "f k' 0 v' = Some Eq" .
      qed
    qed
  qed
qed

lemma lex_ord_pair_valI:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "aux  Some Eq"
  assumes "k  fst ` set xs  fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
    and "k'. k'  fst ` set xs  fst ` set ys  lt k' k 
              f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
  shows "lex_ord_pair f xs ys = aux"
  using assms(1, 2, 4, 5, 6)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
  case Nil
  thus ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    from Nil(1) show ?case by simp
  next
    case (Cons k' v' ys)
    from Cons(6) have "k = k'  k  fst ` set ys" by simp
    thus ?case
    proof
      assume "k = k'"
      with Cons(7) have "f k' 0 v' = aux" by simp
      thus ?thesis by (simp add: Let_def k = k' assms(3))
    next
      assume "k  fst `set ys"
      hence "lt k' k" by (rule Cons(4))
      hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
      hence eq1: "lookup_pair ((k', v') # ys) k = lookup_pair ys k" by simp
      have "f k' (lookup_pair [] k') (lookup_pair ((k', v') # ys) k') = Some Eq"
        by (rule Cons(8), simp, fact)
      hence eq2: "f k' 0 v' = Some Eq" by simp
      show ?thesis
      proof (simp add: Let_def eq2, rule Cons(5))
        from k  fst `set ys show "k  fst ` set []  fst ` set ys" by simp
      next
        show "aux = f k (lookup_pair [] k) (lookup_pair ys k)" by (simp only: Cons(7) eq1)
      next
        fix k0
        assume "lt k0 k"
        assume "k0  fst ` set []  fst ` set ys"
        hence k0_in: "k0  fst ` set ys" by simp
        hence "lt k' k0" by (rule Cons(4))
        hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
        hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) =
                f k0 (lookup_pair [] k0) (lookup_pair ((k', v') # ys) k0)" by simp
        also have "... = Some Eq" by (rule Cons(8), simp add: k0_in, fact)
        finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
      qed
    qed
  qed
next
  case *: (Cons k' v' xs)
  from *(6, 7, 8, 9) show ?case
  proof (induct ys rule: oalist_inv_raw_induct)
    case Nil
    from Nil(1) have "k = k'  k  fst ` set xs" by simp
    thus ?case
    proof
      assume "k = k'"
      with Nil(2) have "f k' v' 0 = aux" by simp
      thus ?thesis by (simp add: Let_def k = k' assms(3))
    next
      assume "k  fst ` set xs"
      hence "lt k' k" by (rule *(4))
      hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
      hence eq1: "lookup_pair ((k', v') # xs) k = lookup_pair xs k" by simp
      have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair [] k') = Some Eq"
        by (rule Nil(3), simp, fact)
      hence eq2: "f k' v' 0 = Some Eq" by simp
      show ?thesis
      proof (simp add: Let_def eq2, rule *(5), fact oalist_inv_raw_Nil)
        from k  fst `set xs show "k  fst ` set xs  fst ` set []" by simp
      next
        show "aux = f k (lookup_pair xs k) (lookup_pair [] k)" by (simp only: Nil(2) eq1)
      next
        fix k0
        assume "lt k0 k"
        assume "k0  fst ` set xs  fst ` set []"
        hence k0_in: "k0  fst ` set xs" by simp
        hence "lt k' k0" by (rule *(4))
        hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
        hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) =
                f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair [] k0)" by simp
        also have "... = Some Eq" by (rule Nil(3), simp add: k0_in, fact)
        finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
      qed
    qed
  next
    case (Cons k'' v'' ys)

    have 0: thesis if 1: "lt k k'" and 2: "lt k k''" for thesis
    proof -
      from 1 have "k  k'" by simp
      moreover from 2 have "k  k''" by simp
      ultimately have "k  fst ` set xs  k  fst ` set ys" using Cons(6) by simp
      thus ?thesis
      proof
        assume "k  fst ` set xs"
        hence "lt k' k" by (rule *(4))
        with 1 show ?thesis by simp
      next
        assume "k  fst ` set ys"
        hence "lt k'' k" by (rule Cons(4))
        with 2 show ?thesis by simp
      qed
    qed

    show ?case
    proof (simp split: order.split, intro conjI impI)
      assume Lt: "comp k' k'' = Lt"
      show "(let aux = f k' v' 0 in if aux = Some Eq then lex_ord_pair f xs ((k'', v'') # ys) else aux) = aux"
      proof (simp add: Let_def split: order.split, intro conjI impI)
        assume "f k' v' 0 = Some Eq"
        have "k  k'"
        proof
          assume "k = k'"
          have "aux = f k v' 0" by (simp add: Cons(7) k = k' Lt)
          with f k' v' 0 = Some Eq› assms(3) show False by (simp add: k = k')
        qed
        from Cons(1) show "lex_ord_pair f xs ((k'', v'') # ys) = aux"
        proof (rule *(5))
          from Cons(6) k  k' show "k  fst ` set xs  fst ` set ((k'', v'') # ys)" by simp
        next
          show "aux = f k (lookup_pair xs k) (lookup_pair ((k'', v'') # ys) k)"
            by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] k  k'[symmetric] del: lookup_pair.simps)
        next
          fix k0
          assume "lt k0 k"
          assume k0_in: "k0  fst ` set xs  fst ` set ((k'', v'') # ys)"
          also have "...  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by fastforce
          finally have k0_in': "k0  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" .
          have "k'  k0"
          proof
            assume "k' = k0"
            with k0_in have "k'  fst ` set xs  fst ` set ((k'', v'') # ys)" by simp
            with Lt have "k'  fst ` set xs  k'  fst ` set ys" by auto
            thus False
            proof
              assume "k'  fst ` set xs"
              hence "lt k' k'" by (rule *(4))
              thus ?thesis by simp
            next
              assume "k'  fst ` set ys"
              hence "lt k'' k'" by (rule Cons(4))
              with Lt show ?thesis by (simp add: Lt_lt_conv)
            qed
          qed
          hence "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) =
                  f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
            by (simp add: lookup_pair_Cons[OF *(1)] del: lookup_pair.simps)
          also from k0_in' ‹lt k0 k have "... = Some Eq" by (rule Cons(8))
          finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) = Some Eq" .
        qed
      next
        assume "f k' v' 0  Some Eq"
        have "¬ lt k' k"
        proof
          have "k'  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by simp
          moreover assume "lt k' k"
          ultimately have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair ((k'', v'') # ys) k') = Some Eq"
            by (rule Cons(8))
          hence "f k' v' 0 = Some Eq" by (simp add: Lt)
          with f k' v' 0  Some Eq› show False ..
        qed
        moreover have "¬ lt k k'"
        proof
          assume "lt k k'"
          moreover from this Lt have "lt k k''" by (simp add: Lt_lt_conv)
          ultimately show False by (rule 0)
        qed
        ultimately have "k = k'" by simp
        show "f k' v' 0 = aux" by (simp add: Cons(7) k = k' Lt)
      qed
    next
      assume "comp k' k'' = Eq"
      hence "k' = k''" by (simp only: eq)
      show "(let aux = f k' v' v'' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = aux"
      proof (simp add: Let_def k' = k'' split: order.split, intro conjI impI)
        assume "f k'' v' v'' = Some Eq"
        have "k  k''"
        proof
          assume "k = k''"
          have "aux = f k v' v''" by (simp add: Cons(7) k = k'' k' = k'')
          with f k'' v' v'' = Some Eq› assms(3) show False by (simp add: k = k'')
        qed
        from Cons(2) show "lex_ord_pair f xs ys = aux"
        proof (rule *(5))
          from Cons(6) k  k'' show "k  fst ` set xs  fst ` set ys" by (simp add: k' = k'')
        next
          show "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
            by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
                simp add: k' = k'' k  k''[symmetric])
        next
          fix k0
          assume "lt k0 k"
          assume k0_in: "k0  fst ` set xs  fst ` set ys"
          also have "...  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by fastforce
          finally have k0_in': "k0  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" .
          have "k''  k0"
          proof
            assume "k'' = k0"
            with k0_in have "k''  fst ` set xs  fst ` set ys" by simp
            thus False
            proof
              assume "k''  fst ` set xs"
              hence "lt k' k''" by (rule *(4))
              thus ?thesis by (simp add: k' = k'')
            next
              assume "k''  fst ` set ys"
              hence "lt k'' k''" by (rule Cons(4))
              thus ?thesis by simp
            qed
          qed
          hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
                  f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
            by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
                simp add: k' = k'')
          also from k0_in' ‹lt k0 k have "... = Some Eq" by (rule Cons(8))
          finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
        qed
      next
        assume "f k'' v' v''  Some Eq"
        have "¬ lt k'' k"
        proof
          have "k''  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by simp
          moreover assume "lt k'' k"
          ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
            by (rule Cons(8))
          hence "f k'' v' v'' = Some Eq" by (simp add: k' = k'')
          with f k'' v' v''  Some Eq› show False ..
        qed
        moreover have "¬ lt k k''"
        proof
          assume "lt k k''"
          hence "lt k k'" by (simp only: k' = k'')
          thus False using ‹lt k k'' by (rule 0)
        qed
        ultimately have "k = k''" by simp
        show "f k'' v' v'' = aux" by (simp add: Cons(7) k = k'' k' = k'')
      qed
    next
      assume Gt: "comp k' k'' = Gt"
      hence Lt: "comp k'' k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
      show "(let aux = f k'' 0 v'' in if aux = Some Eq then lex_ord_pair f ((k', v') # xs) ys else aux) = aux"
      proof (simp add: Let_def split: order.split, intro conjI impI)
        assume "f k'' 0 v'' = Some Eq"
        have "k  k''"
        proof
          assume "k = k''"
          have "aux = f k 0 v''" by (simp add: Cons(7) k = k'' Lt)
          with f k'' 0 v'' = Some Eq› assms(3) show False by (simp add: k = k'')
        qed
        show "lex_ord_pair f ((k', v') # xs) ys = aux"
        proof (rule Cons(5))
          from Cons(6) k  k'' show "k  fst ` set ((k', v') # xs)  fst ` set ys" by simp
        next
          show "aux = f k (lookup_pair ((k', v') # xs) k) (lookup_pair ys k)"
            by (simp add: Cons(7) lookup_pair_Cons[OF Cons(1)] k  k''[symmetric] del: lookup_pair.simps)
        next
          fix k0
          assume "lt k0 k"
          assume k0_in: "k0  fst ` set ((k', v') # xs)  fst ` set ys"
          also have "...  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by fastforce
          finally have k0_in': "k0  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" .
          have "k''  k0"
          proof
            assume "k'' = k0"
            with k0_in have "k''  fst ` set ((k', v') # xs)  fst ` set ys" by simp
            with Lt have "k''  fst ` set xs  k''  fst ` set ys" by auto
            thus False
            proof
              assume "k''  fst ` set xs"
              hence "lt k' k''" by (rule *(4))
              with Lt show ?thesis by (simp add: Lt_lt_conv)
            next
              assume "k''  fst ` set ys"
              hence "lt k'' k''" by (rule Cons(4))
              thus ?thesis by simp
            qed
          qed
          hence "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) =
                  f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
            by (simp add: lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps)
          also from k0_in' ‹lt k0 k have "... = Some Eq" by (rule Cons(8))
          finally show "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) = Some Eq" .
        qed
      next
        assume "f k'' 0 v''  Some Eq"
        have "¬ lt k'' k"
        proof
          have "k''  fst ` set ((k', v') # xs)  fst ` set ((k'', v'') # ys)" by simp
          moreover assume "lt k'' k"
          ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
            by (rule Cons(8))
          hence "f k'' 0 v'' = Some Eq" by (simp add: Lt)
          with f k'' 0 v''  Some Eq› show False ..
        qed
        moreover have "¬ lt k k''"
        proof
          assume "lt k k''"
          with Lt have "lt k k'" by (simp add: Lt_lt_conv)
          thus False using ‹lt k k'' by (rule 0)
        qed
        ultimately have "k = k''" by simp
        show "f k'' 0 v'' = aux" by (simp add: Cons(7) k = k'' Lt)
      qed
    qed
  qed
qed

lemma lex_ord_pair_EqD:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = Some Eq"
    and "k  fst ` set xs  fst ` set ys"
  shows "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
proof (rule ccontr)
  let ?A = "(fst ` set xs  fst ` set ys)  {k. f k (lookup_pair xs k) (lookup_pair ys k)  Some Eq}"
  define k0 where "k0 = Min ?A"
  have "finite ?A" by auto
  assume "f k (lookup_pair xs k) (lookup_pair ys k)  Some Eq"
  with assms(4) have "k  ?A" by simp
  hence "?A  {}" by blast
  with ‹finite ?A have "k0  ?A" unfolding k0_def by (rule Min_in)
  hence k0_in: "k0  fst ` set xs  fst ` set ys"
    and neq: "f k0 (lookup_pair xs k0) (lookup_pair ys k0)  Some Eq" by simp_all
  have "le k0 k'" if "k'  ?A" for k' unfolding k0_def using ‹finite ?A that
    by (rule Min_le)
  hence "f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
    if "k'  fst ` set xs  fst ` set ys" and "lt k' k0" for k' using that by fastforce
  with assms(1, 2) neq k0_in HOL.refl have "lex_ord_pair f xs ys = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
    by (rule lex_ord_pair_valI)
  with assms(3) neq show False by simp
qed

lemma lex_ord_pair_valE:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = aux"
    and "aux  Some Eq"
  obtains k where "k  fst ` set xs  fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
    and "k'. k'  fst ` set xs  fst ` set ys  lt k' k 
            f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
proof -
  let ?A = "(fst ` set xs  fst ` set ys)  {k. f k (lookup_pair xs k) (lookup_pair ys k)  Some Eq}"
  define k where "k = Min ?A"
  have "finite ?A" by auto
  have "k  fst ` set xs  fst ` set ys. f k (lookup_pair xs k) (lookup_pair ys k)  Some Eq" (is ?prop)
  proof (rule ccontr)
    assume "¬ ?prop"
    hence "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
      if "k  fst ` set xs  fst ` set ys" for k using that by auto
    with assms(1, 2) have "lex_ord_pair f xs ys = Some Eq" by (rule lex_ord_pair_EqI)
    with assms(3, 4) show False by simp
  qed
  then obtain k0 where "k0  fst ` set xs  fst ` set ys"
    and "f k0 (lookup_pair xs k0) (lookup_pair ys k0)  Some Eq" ..
  hence "k0  ?A" by simp
  hence "?A  {}" by blast
  with ‹finite ?A have "k  ?A" unfolding k_def by (rule Min_in)
  hence k_in: "k  fst ` set xs  fst ` set ys"
    and neq: "f k (lookup_pair xs k) (lookup_pair ys k)  Some Eq" by simp_all
  have "le k k'" if "k'  ?A" for k' unfolding k_def using ‹finite ?A that
    by (rule Min_le)
  hence *: "k'. k'  fst ` set xs  fst ` set ys  lt k' k 
            f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq" by fastforce
  with assms(1, 2) neq k_in HOL.refl have "lex_ord_pair f xs ys = f k (lookup_pair xs k) (lookup_pair ys k)"
    by (rule lex_ord_pair_valI)
  hence "aux = f k (lookup_pair xs k) (lookup_pair ys k)" by (simp only: assms(3))
  with k_in show ?thesis using * ..
qed

subsubsection @{const prod_ord_pair}

lemma prod_ord_pair_eq_lex_ord_pair:
  "prod_ord_pair P xs ys = (lex_ord_pair (λk x y. if P k x y then Some Eq else None) xs ys = Some Eq)"
proof (induct P xs ys rule: prod_ord_pair.induct)
  case (1 P)
  show ?case by simp
next
  case (2 P ky vy ys)
  thus ?case by simp
next
  case (3 P kx vx xs)
  thus ?case by simp
next
  case (4 P kx vx xs ky vy ys)
  show ?case
  proof (cases "comp kx ky")
    case Lt
    thus ?thesis by (simp add: 4(2)[OF Lt])
  next
    case Eq
    thus ?thesis by (simp add: 4(1)[OF Eq])
  next
    case Gt
    thus ?thesis by (simp add: 4(3)[OF Gt])
  qed
qed

lemma prod_ord_pairI:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
    and "k. k  fst ` set xs  fst ` set ys  P k (lookup_pair xs k) (lookup_pair ys k)"
  shows "prod_ord_pair P xs ys"
  unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqI, fact, fact, simp add: assms(3))

lemma prod_ord_pairD:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "prod_ord_pair P xs ys"
    and "k  fst ` set xs  fst ` set ys"
  shows "P k (lookup_pair xs k) (lookup_pair ys k)"
proof -
  from assms have "(if P k (lookup_pair xs k) (lookup_pair ys k) then Some Eq else None) = Some Eq"
    unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqD)
  thus ?thesis by (simp split: if_splits)
qed

corollary prod_ord_pair_alt:
  assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
  shows "(prod_ord_pair P xs ys)  (kfst ` set xs  fst ` set ys. P k (lookup_pair xs k) (lookup_pair ys k))"
  using prod_ord_pairI[OF assms] prod_ord_pairD[OF assms] by meson

subsubsection @{const sort_oalist}

lemma oalist_inv_raw_foldr_update_by_pair:
  assumes "oalist_inv_raw ys"
  shows "oalist_inv_raw (foldr update_by_pair xs ys)"
proof (induct xs)
  case Nil
  from assms show ?case by simp
next
  case (Cons x xs)
  hence "oalist_inv_raw (update_by_pair x (foldr update_by_pair xs ys))"
    by (rule oalist_inv_raw_update_by_pair)
  thus ?case by simp
qed

corollary oalist_inv_raw_sort_oalist: "oalist_inv_raw (sort_oalist xs)"
proof -
  from oalist_inv_raw_Nil have "oalist_inv_raw (foldr local.update_by_pair xs [])"
    by (rule oalist_inv_raw_foldr_update_by_pair)
  thus "oalist_inv_raw (sort_oalist xs)" by (simp only: sort_oalist_def)
qed

lemma sort_oalist_id:
  assumes "oalist_inv_raw xs"
  shows "sort_oalist xs = xs"
proof -
  have "foldr update_by_pair xs ys = xs @ ys" if "oalist_inv_raw (xs @ ys)" for ys using assms that
  proof (induct xs rule: oalist_inv_raw_induct)
    case Nil
    show ?case by simp
  next
    case (Cons k v xs)
    from Cons(6) have *: "oalist_inv_raw ((k, v) # (xs @ ys))" by simp
    hence 1: "oalist_inv_raw (xs @ ys)" by (rule oalist_inv_raw_ConsD1)
    hence 2: "foldr update_by_pair xs ys = xs @ ys" by (rule Cons(5))
    show ?case
    proof (simp add: 2, rule update_by_pair_less)
      from * show "v  0" by (auto simp: oalist_inv_raw_def)
    next
      have "comp k (fst (hd (xs @ ys))) = Lt  xs @ ys = []"
      proof (rule disjCI)
        assume "xs @ ys  []"
        then obtain k'' v'' zs where eq0: "xs @ ys = (k'', v'') # zs"
          using list.exhaust prod.exhaust by metis
        from * have "lt k k''" by (simp add: eq0 oalist_inv_raw_def)
        thus "comp k (fst (hd (xs @ ys))) = Lt" by (simp add: eq0 Lt_lt_conv)
      qed
      thus "xs @ ys = []  comp k (fst (hd (xs @ ys))) = Lt" by auto
    qed
  qed
  with assms show ?thesis by (simp add: sort_oalist_def)
qed

lemma set_sort_oalist:
  assumes "distinct (map fst xs)"
  shows "set (sort_oalist xs) = {kv. kv  set xs  snd kv  0}"
  using assms
proof (induct xs)
  case Nil
  show ?case by (simp add: sort_oalist_def)
next
  case (Cons x xs)
  obtain k v where x: "x = (k, v)" by fastforce
  from Cons(2) have "distinct (map fst xs)" and "k  fst ` set xs" by (simp_all add: x)
  from this(1) have "set (sort_oalist xs) = {kv  set xs. snd kv  0}" by (rule Cons(1))
  with k  fst ` set xs have eq: "set (sort_oalist xs) - range (Pair k) = {kv  set xs. snd kv  0}"
    by (auto simp: image_iff)
  have "set (sort_oalist (x # xs)) = set (update_by_pair (k, v) (sort_oalist xs))"
    by (simp add: sort_oalist_def x)
  also have "... = {kv  set (x # xs). snd kv  0}"
  proof (cases "v = 0")
    case True
    have "set (update_by_pair (k, v) (sort_oalist xs)) = set (sort_oalist xs) - range (Pair k)"
      unfolding True using oalist_inv_raw_sort_oalist by (rule set_update_by_pair_zero)
    also have "... = {kv  set (x # xs). snd kv  0}" by (auto simp: eq x True)
    finally show ?thesis .
  next
    case False
    with oalist_inv_raw_sort_oalist
    have "set (update_by_pair (k, v) (sort_oalist xs)) = insert (k, v) (set (sort_oalist xs) - range (Pair k))"
      by (rule set_update_by_pair)
    also have "... = {kv  set (x # xs). snd kv  0}" by (auto simp: eq x False)
    finally show ?thesis .
  qed
  finally show ?case .
qed

lemma lookup_pair_sort_oalist':
  assumes "distinct (map fst xs)"
  shows "lookup_pair (sort_oalist xs) = lookup_dflt xs"
  using assms
proof (induct xs)
  case Nil
  show ?case by (simp add: sort_oalist_def lookup_dflt_def)
next
  case (Cons x xs)
  obtain k v where x: "x = (k, v)" by fastforce
  from Cons(2) have "distinct (map fst xs)" and "k  fst ` set xs" by (simp_all add: x)
  from this(1) have eq1: "lookup_pair (sort_oalist xs) = lookup_dflt xs" by (rule Cons(1))
  have eq2: "sort_oalist (x # xs) = update_by_pair (k, v) (sort_oalist xs)" by (simp add: x sort_oalist_def)
  show ?case
  proof
    fix k'
    have "lookup_pair (sort_oalist (x # xs)) k' = (if k = k' then v else lookup_dflt xs k')"
      by (simp add: eq1 eq2 lookup_pair_update_by_pair[OF oalist_inv_raw_sort_oalist])
    also have "... = lookup_dflt (x # xs) k'" by (simp add: x lookup_dflt_def)
    finally show "lookup_pair (sort_oalist (x # xs)) k' = lookup_dflt (x # xs) k'" .
  qed
qed

end

locale comparator2 = comparator comp1 + cmp2: comparator comp2 for comp1 comp2 :: "'a comparator"
begin

lemma set_sort_oalist:
  assumes "cmp2.oalist_inv_raw xs"
  shows "set (sort_oalist xs) = set xs"
proof -
  have rl: "set (foldr update_by_pair xs ys) = set xs  set ys"
    if "oalist_inv_raw ys" and "fst ` set xs  fst ` set ys = {}" for ys
    using assms that(2)
  proof (induct xs rule: cmp2.oalist_inv_raw_induct)
    case Nil
    show ?case by simp
  next
    case (Cons k v xs)
    from Cons(6) have "k  fst ` set ys" and "fst ` set xs  fst ` set ys = {}" by simp_all
    from this(2) have eq1: "set (foldr update_by_pair xs ys) = set xs  set ys" by (rule Cons(5))
    have "¬ cmp2.lt k k" by auto
    with Cons(4) have "k  fst ` set xs" by blast
    with k  fst ` set ys have "k  fst ` (set xs  set ys)" by (simp add: image_Un)
    hence "(set xs  set ys)  range (Pair k) = {}" by (smt Int_emptyI fstI image_iff)
    hence eq2: "(set xs  set ys) - range (Pair k) = set xs  set ys" by (rule Diff_triv)
    from ‹oalist_inv_raw ys have "oalist_inv_raw (foldr update_by_pair xs ys)"
      by (rule oalist_inv_raw_foldr_update_by_pair)
    hence "set (update_by_pair (k, v) (foldr update_by_pair xs ys)) =
            insert (k, v) (set (foldr update_by_pair xs ys) - range (Pair k))"
      using Cons(3) by (rule set_update_by_pair)
    also have "... = insert (k, v) (set xs  set ys)" by (simp only: eq1 eq2)
    finally show ?case by simp
  qed
  have "set (foldr update_by_pair xs []) = set xs  set []"
    by (rule rl, fact oalist_inv_raw_Nil, simp)
  thus ?thesis by (simp add: sort_oalist_def)
qed

lemma lookup_pair_eqI:
  assumes "oalist_inv_raw xs" and "cmp2.oalist_inv_raw ys" and "set xs = set ys"
  shows "lookup_pair xs = cmp2.lookup_pair ys"
proof
  fix k
  show "lookup_pair xs k = cmp2.lookup_pair ys k"
  proof (cases "cmp2.lookup_pair ys k = 0")
    case True
    with assms(2) have "k  fst ` set ys" by (simp add: cmp2.lookup_pair_eq_0)
    with assms(1) show ?thesis by (simp add: True assms(3)[symmetric] lookup_pair_eq_0)
  next
    case False
    define v where "v = cmp2.lookup_pair ys k"
    from False have "v  0" by (simp add: v_def)
    with assms(2) v_def[symmetric] have "(k, v)  set ys" by (simp add: cmp2.lookup_pair_eq_value)
    with assms(1) v  0 have "lookup_pair xs k = v"
      by (simp add: assms(3)[symmetric] lookup_pair_eq_value)
    thus ?thesis by (simp only: v_def)
  qed
qed

corollary lookup_pair_sort_oalist:
  assumes "cmp2.oalist_inv_raw xs"
  shows "lookup_pair (sort_oalist xs) = cmp2.lookup_pair xs"
  by (rule lookup_pair_eqI, rule oalist_inv_raw_sort_oalist, fact, rule set_sort_oalist, fact)

end (* comparator2 *)

subsection ‹Invariant on Pairs›

type_synonym ('a, 'b, 'c) oalist_raw = "('a × 'b) list × 'c"

locale oalist_raw = fixes rep_key_order::"'o  'a key_order"
begin

sublocale comparator "key_compare (rep_key_order x)"
  by (fact comparator_key_compare)

definition oalist_inv :: "('a, 'b::zero, 'o) oalist_raw  bool"
  where "oalist_inv xs  oalist_inv_raw (snd xs) (fst xs)"

lemma oalist_inv_alt: "oalist_inv (xs, ko)  oalist_inv_raw ko xs"
  by (simp add: oalist_inv_def)

subsection ‹Operations on Raw Ordered Associative Lists›

fun sort_oalist_aux :: "'o  ('a, 'b, 'o) oalist_raw  ('a × 'b::zero) list"
  where "sort_oalist_aux ko (xs, ox) = (if ko = ox then xs else sort_oalist ko xs)"

fun lookup_raw :: "('a, 'b, 'o) oalist_raw  'a  'b::zero"
  where "lookup_raw (xs, ko) = lookup_pair ko xs"

definition sorted_domain_raw :: "'o  ('a, 'b::zero, 'o) oalist_raw  'a list"
  where "sorted_domain_raw ko xs = map fst (sort_oalist_aux ko xs)"

fun tl_raw :: "('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw"
  where "tl_raw (xs, ko) = (List.tl xs, ko)"

fun min_key_val_raw :: "'o  ('a, 'b, 'o) oalist_raw  ('a × 'b::zero)"
  where "min_key_val_raw ko (xs, ox) =
      (if ko = ox then List.hd else min_list_param (λx y. le ko (fst x) (fst y))) xs"

fun update_by_raw :: "('a × 'b)  ('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw"
  where "update_by_raw kv (xs, ko) = (update_by_pair ko kv xs, ko)"

fun update_by_fun_raw :: "'a  ('b  'b)  ('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw"
  where "update_by_fun_raw k f (xs, ko) = (update_by_fun_pair ko k f xs, ko)"

fun update_by_fun_gr_raw :: "'a  ('b  'b)  ('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw"
  where "update_by_fun_gr_raw k f (xs, ko) = (update_by_fun_gr_pair ko k f xs, ko)"

fun (in -) filter_raw :: "('a  bool)  ('a list × 'b)  ('a list × 'b)"
  where "filter_raw P (xs, ko) = (filter P xs, ko)"

fun (in -) map_raw :: "(('a × 'b)  ('a × 'c))  (('a × 'b::zero) list × 'd)  ('a × 'c::zero) list × 'd"
  where "map_raw f (xs, ko) = (map_pair f xs, ko)"

abbreviation (in -) "map_val_raw f  map_raw (λ(k, v). (k, f k v))"

fun map2_val_raw :: "('a  'b  'c  'd)  (('a, 'b, 'o) oalist_raw  ('a, 'd, 'o) oalist_raw) 
                      (('a, 'c, 'o) oalist_raw  ('a, 'd, 'o) oalist_raw) 
                      ('a, 'b::zero, 'o) oalist_raw  ('a, 'c::zero, 'o) oalist_raw 
                      ('a, 'd::zero, 'o) oalist_raw"
  where "map2_val_raw f g h (xs, ox) ys =
            (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox)))
                    xs (sort_oalist_aux ox ys), ox)"

definition lex_ord_raw :: "'o  ('a  (('b, 'c) comp_opt)) 
                      (('a, 'b::zero, 'o) oalist_raw, ('a, 'c::zero, 'o) oalist_raw) comp_opt"
  where "lex_ord_raw ko f xs ys = lex_ord_pair ko f (sort_oalist_aux ko xs) (sort_oalist_aux ko ys)"

fun prod_ord_raw :: "('a  'b  'c  bool)  ('a, 'b::zero, 'o) oalist_raw 
                      ('a, 'c::zero, 'o) oalist_raw  bool"
  where "prod_ord_raw f (xs, ox) ys = prod_ord_pair ox f xs (sort_oalist_aux ox ys)"

fun oalist_eq_raw :: "('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw  bool"
  where "oalist_eq_raw (xs, ox) ys = (xs = (sort_oalist_aux ox ys))"

fun sort_oalist_raw :: "('a, 'b, 'o) oalist_raw  ('a, 'b::zero, 'o) oalist_raw"
  where "sort_oalist_raw (xs, ko) = (sort_oalist ko xs, ko)"

subsubsection @{const sort_oalist_aux}

lemma set_sort_oalist_aux:
  assumes "oalist_inv xs"
  shows "set (sort_oalist_aux ko xs) = set (fst xs)"
proof -
  obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
  interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
  from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.set_sort_oalist)
qed

lemma oalist_inv_raw_sort_oalist_aux:
  assumes "oalist_inv xs"
  shows "oalist_inv_raw ko (sort_oalist_aux ko xs)"
proof -
  obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
  from assms show ?thesis by (simp add: xs oalist_inv_alt oalist_inv_raw_sort_oalist)
qed

lemma oalist_inv_sort_oalist_aux:
  assumes "oalist_inv xs"
  shows "oalist_inv (sort_oalist_aux ko xs, ko)"
  unfolding oalist_inv_alt using assms by (rule oalist_inv_raw_sort_oalist_aux)

lemma lookup_pair_sort_oalist_aux:
  assumes "oalist_inv xs"
  shows "lookup_pair ko (sort_oalist_aux ko xs) = lookup_raw xs"
proof -
  obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
  interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
  from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.lookup_pair_sort_oalist)
qed

subsubsection @{const lookup_raw}

lemma lookup_raw_eq_value:
  assumes "oalist_inv xs" and "v  0"
  shows "lookup_raw xs k = v  ((k, v)  set (fst xs))"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
  show ?thesis by (simp add: xs, rule lookup_pair_eq_value, fact+)
qed

lemma lookup_raw_eq_valueI:
  assumes "oalist_inv xs" and "(k, v)  set (fst xs)"
  shows "lookup_raw xs k = v"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
  from assms(2) have "(k, v)  set xs'" by (simp add: xs)
  show ?thesis by (simp add: xs, rule lookup_pair_eq_valueI, fact+)
qed

lemma lookup_raw_inj:
  assumes "oalist_inv (xs, ko)" and "oalist_inv (ys, ko)" and "lookup_raw (xs, ko) = lookup_raw (ys, ko)"
  shows "xs = ys"
  using assms unfolding lookup_raw.simps oalist_inv_alt by (rule lookup_pair_inj)

subsubsection @{const sorted_domain_raw}

lemma set_sorted_domain_raw:
  assumes "oalist_inv xs"
  shows "set (sorted_domain_raw ko xs) = fst ` set (fst xs)"
  using assms by (simp add: sorted_domain_raw_def set_sort_oalist_aux)

corollary in_sorted_domain_raw_iff_lookup_raw:
  assumes "oalist_inv xs"
  shows "k  set (sorted_domain_raw ko xs)  (lookup_raw xs k  0)"
  unfolding set_sorted_domain_raw[OF assms]
proof -
  obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
  from assms show "k  fst ` set (fst xs)  (lookup_raw xs k  0)"
    by (simp add: xs oalist_inv_alt lookup_pair_eq_0)
qed

lemma sorted_sorted_domain_raw:
  assumes "oalist_inv xs"
  shows "sorted_wrt (lt_of_key_order (rep_key_order ko)) (sorted_domain_raw ko xs)"
  unfolding sorted_domain_raw_def oalist_inv_alt lt_of_key_order.rep_eq
  by (rule oalist_inv_rawD2, rule oalist_inv_raw_sort_oalist_aux, fact)

subsubsection @{const tl_raw}

lemma oalist_inv_tl_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (tl_raw xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs tl_raw.simps oalist_inv_alt by (rule oalist_inv_raw_tl)
qed

lemma lookup_raw_tl_raw:
  assumes "oalist_inv xs"
  shows "lookup_raw (tl_raw xs) k =
          (if (k'fst ` set (fst xs). le (snd xs) k k') then 0 else lookup_raw xs k)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis by (simp add: xs lookup_pair_tl oalist_inv_alt split del: if_split cong: if_cong)
qed

lemma lookup_raw_tl_raw':
  assumes "oalist_inv xs"
  shows "lookup_raw (tl_raw xs) k = (if k = fst (List.hd (fst xs)) then 0 else lookup_raw xs k)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis by (simp add: xs lookup_pair_tl' oalist_inv_alt)
qed

subsubsection @{const min_key_val_raw}

lemma min_key_val_raw_alt:
  assumes "oalist_inv xs" and "fst xs  []"
  shows "min_key_val_raw ko xs = List.hd (sort_oalist_aux ko xs)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(2) have "xs'  []" by (simp add: xs)
  interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ox)" ..
  from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
  hence set_sort: "set (sort_oalist ko xs') = set xs'" by (rule ko2.set_sort_oalist)
  also from xs'  [] have "...  {}" by simp
  finally have "sort_oalist ko xs'  []" by simp
  then obtain k v xs'' where eq: "sort_oalist ko xs' = (k, v) # xs''"
    using prod.exhaust list.exhaust by metis
  hence "(k, v)  set xs'" by (simp add: set_sort[symmetric])
  have *: "le ko k k'" if "k'  fst ` set xs'" for k'
  proof -
    from that have "k' = k  k'  fst ` set xs''" by (simp add: set_sort[symmetric] eq)
    thus ?thesis
    proof
      assume "k' = k"
      thus ?thesis by simp
    next
      have "oalist_inv_raw ko ((k, v) # xs'')" unfolding eq[symmetric] by (fact oalist_inv_raw_sort_oalist)
      moreover assume "k'  fst ` set xs''"
      ultimately have "lt ko k k'" by (rule oalist_inv_raw_ConsD3)
      thus ?thesis by simp
    qed
  qed
  from xs'  [] have "min_list_param (λx y. le ko (fst x) (fst y)) xs'  set xs'" by (rule min_list_param_in)
  with ‹oalist_inv_raw ox xs' have "lookup_pair ox xs' (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) =
    snd (min_list_param (λx y. le ko (fst x) (fst y)) xs')" by (auto intro: lookup_pair_eq_valueI)
  moreover have 1: "fst (min_list_param (λx y. le ko (fst x) (fst y)) xs') = k"
  proof (rule antisym)
    from order_trans
    have "transp (λx y. le ko (fst x) (fst y))" by (rule transpI)
    hence "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) (fst (k, v))"
      using linear (k, v)  set xs' by (rule min_list_param_minimal)
    thus "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) k" by simp
  next
    show "le ko k (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs'))" by (rule *, rule imageI, fact)
  qed
  ultimately have "snd (min_list_param (λx y. le ko (fst x) (fst y)) xs') = lookup_pair ox xs' k"
    by simp
  also from ‹oalist_inv_raw ox xs' (k, v)  set xs' have "... = v" by (rule lookup_pair_eq_valueI)
  finally have "snd (min_list_param (λx y. le ko (fst x) (fst y)) xs') = v" .
  with 1 have "min_list_param (λx y. le ko (fst x) (fst y)) xs' = (k, v)" by auto
  thus ?thesis by (simp add: xs eq)
qed

lemma min_key_val_raw_in:
  assumes "fst xs  []"
  shows "min_key_val_raw ko xs  set (fst xs)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms have "xs'  []" by (simp add: xs)
  show ?thesis unfolding xs
  proof (simp, intro conjI impI)
    from xs'  [] show "hd xs'  set xs'" by simp
  next
    from xs'  [] show "min_list_param (λx y. le ko (fst x) (fst y)) xs'  set xs'"
      by (rule min_list_param_in)
  qed
qed

lemma snd_min_key_val_raw:
  assumes "oalist_inv xs" and "fst xs  []"
  shows "snd (min_key_val_raw ko xs) = lookup_raw xs (fst (min_key_val_raw ko xs))"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
  from assms(2) have "min_key_val_raw ko xs  set (fst xs)" by (rule min_key_val_raw_in)
  hence *: "min_key_val_raw ko (xs', ox)  set xs'" by (simp add: xs)
  show ?thesis unfolding xs lookup_raw.simps
    by (rule HOL.sym, rule lookup_pair_eq_valueI, fact, simp add: * del: min_key_val_raw.simps)
qed

lemma min_key_val_raw_minimal:
  assumes "oalist_inv xs" and "z  set (fst xs)"
  shows "le ko (fst (min_key_val_raw ko xs)) (fst z)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms have "oalist_inv (xs', ox)" and "z  set xs'" by (simp_all add: xs)
  show ?thesis unfolding xs
  proof (simp, intro conjI impI)
    from z  set xs' have "xs'  []" by auto
    then obtain k v ys where xs': "xs' = (k, v) # ys" using prod.exhaust list.exhaust by metis
    from z  set xs' have "z = (k, v)  z  set ys" by (simp add: xs')
    thus "le ox (fst (hd xs')) (fst z)"
    proof
      assume "z = (k, v)"
      show ?thesis by (simp add: xs' z = (k, v))
    next
      assume "z  set ys"
      hence "fst z  fst ` set ys" by fastforce
      with ‹oalist_inv (xs', ox) have "lt ox k (fst z)"
        unfolding xs' oalist_inv_alt lt_of_key_order.rep_eq by (rule oalist_inv_raw_ConsD3)
      thus ?thesis by (simp add: xs')
    qed
  next
    show "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) (fst z)"
    proof (rule min_list_param_minimal[of "λx y. le ko (fst x) (fst y)"])
      thm trans local.trans order.trans local.order_trans
      print_context
      show "transp (λx y. le ko (fst x) (fst y))" by (metis (no_types, lifting) order_trans transpI)
    qed (auto intro: z  set xs')
  qed
qed

subsubsection @{const filter_raw}

lemma oalist_inv_filter_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (filter_raw P xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs filter_raw.simps oalist_inv_alt
    by (rule oalist_inv_raw_filter)
qed

lemma lookup_raw_filter_raw:
  assumes "oalist_inv xs"
  shows "lookup_raw (filter_raw P xs) k = (let v = lookup_raw xs k in if P (k, v) then v else 0)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs lookup_raw.simps filter_raw.simps oalist_inv_alt
    by (rule lookup_pair_filter)
qed

subsubsection @{const update_by_raw}

lemma oalist_inv_update_by_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (update_by_raw kv xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs update_by_raw.simps oalist_inv_alt
    by (rule oalist_inv_raw_update_by_pair)
qed

lemma lookup_raw_update_by_raw:
  assumes "oalist_inv xs"
  shows "lookup_raw (update_by_raw (k1, v) xs) k2 = (if k1 = k2 then v else lookup_raw xs k2)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs lookup_raw.simps update_by_raw.simps oalist_inv_alt
    by (rule lookup_pair_update_by_pair)
qed

subsubsection @{const update_by_fun_raw} and @{const update_by_fun_gr_raw}

lemma update_by_fun_raw_eq_update_by_raw:
  assumes "oalist_inv xs"
  shows "update_by_fun_raw k f xs = update_by_raw (k, f (lookup_raw xs k)) xs"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
  show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_raw.simps
    by (rule, rule conjI, rule update_by_fun_pair_eq_update_by_pair, fact, fact HOL.refl)
qed

corollary oalist_inv_update_by_fun_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (update_by_fun_raw k f xs)"
  unfolding update_by_fun_raw_eq_update_by_raw[OF assms] using assms by (rule oalist_inv_update_by_raw)

corollary lookup_raw_update_by_fun_raw:
  assumes "oalist_inv xs"
  shows "lookup_raw (update_by_fun_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
  using assms by (simp add: update_by_fun_raw_eq_update_by_raw lookup_raw_update_by_raw)

lemma update_by_fun_gr_raw_eq_update_by_fun_raw:
  assumes "oalist_inv xs"
  shows "update_by_fun_gr_raw k f xs = update_by_fun_raw k f xs"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
  show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_fun_gr_raw.simps
    by (rule, rule conjI, rule update_by_fun_gr_pair_eq_update_by_fun_pair, fact, fact HOL.refl)
qed

corollary oalist_inv_update_by_fun_gr_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (update_by_fun_gr_raw k f xs)"
  unfolding update_by_fun_gr_raw_eq_update_by_fun_raw[OF assms] using assms by (rule oalist_inv_update_by_fun_raw)

corollary lookup_raw_update_by_fun_gr_raw:
  assumes "oalist_inv xs"
  shows "lookup_raw (update_by_fun_gr_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
  using assms by (simp add: update_by_fun_gr_raw_eq_update_by_fun_raw lookup_raw_update_by_fun_raw)

subsubsection @{const map_raw} and @{const map_val_raw}

lemma map_raw_cong:
  assumes "kv. kv  set (fst xs)  f kv = g kv"
  shows "map_raw f xs = map_raw g xs"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "f kv = g kv" if "kv  set xs'" for kv using that by (simp add: xs)
  thus ?thesis by (simp add: xs, rule map_pair_cong)
qed

lemma map_raw_subset: "set (fst (map_raw f xs))  f ` set (fst xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  show ?thesis by (simp add: xs map_pair_subset)
qed

lemma oalist_inv_map_raw:
  assumes "oalist_inv xs"
    and "a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
  shows "oalist_inv (map_raw f xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
  moreover from assms(2)
  have "a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
    by (simp add: xs)
  ultimately show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_pair)
qed

lemma lookup_raw_map_raw:
  assumes "oalist_inv xs" and "snd (f (k, 0)) = 0"
    and "a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
  shows "lookup_raw (map_raw f xs) (fst (f (k, v))) = snd (f (k, lookup_raw xs k))"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
  moreover note assms(2)
  moreover from assms(3)
  have "a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
    by (simp add: xs)
  ultimately show ?thesis unfolding xs lookup_raw.simps map_raw.simps oalist_inv_alt
    by (rule lookup_pair_map_pair)
qed

lemma map_raw_id:
  assumes "oalist_inv xs"
  shows "map_raw id xs = xs"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
  hence "map_pair id xs' = xs'"
  proof (induct xs' rule: oalist_inv_raw_induct)
    case Nil
    show ?case by simp
  next
    case (Cons k v xs')
    show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
  qed
  thus ?thesis by (simp add: xs)
qed

lemma map_val_raw_cong:
  assumes "k v. (k, v)  set (fst xs)  f k v = g k v"
  shows "map_val_raw f xs = map_val_raw g xs"
proof (rule map_raw_cong)
  fix kv
  assume "kv  set (fst xs)"
  moreover obtain k v where "kv = (k, v)" by fastforce
  ultimately show "(case kv of (k, v)  (k, f k v)) = (case kv of (k, v)  (k, g k v))"
    by (simp add: assms)
qed

lemma oalist_inv_map_val_raw:
  assumes "oalist_inv xs"
  shows "oalist_inv (map_val_raw f xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_val_pair)
qed

lemma lookup_raw_map_val_raw:
  assumes "oalist_inv xs" and "f k 0 = 0"
  shows "lookup_raw (map_val_raw f xs) k = f k (lookup_raw xs k)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms show ?thesis unfolding xs map_raw.simps lookup_raw.simps oalist_inv_alt
    by (rule lookup_pair_map_val_pair)
qed

subsubsection @{const map2_val_raw}

definition map2_val_compat' :: "(('a, 'b::zero, 'o) oalist_raw  ('a, 'c::zero, 'o) oalist_raw)  bool"
  where "map2_val_compat' f 
      (zs. (oalist_inv zs  (oalist_inv (f zs)  snd (f zs) = snd zs  fst ` set (fst (f zs))  fst ` set (fst zs))))"

lemma map2_val_compat'I:
  assumes "zs. oalist_inv zs  oalist_inv (f zs)"
    and "zs. oalist_inv zs  snd (f zs) = snd zs"
    and "zs. oalist_inv zs  fst ` set (fst (f zs))  fst ` set (fst zs)"
  shows "map2_val_compat' f"
  unfolding map2_val_compat'_def using assms by blast

lemma map2_val_compat'D1:
  assumes "map2_val_compat' f" and "oalist_inv zs"
  shows "oalist_inv (f zs)"
  using assms unfolding map2_val_compat'_def by blast

lemma map2_val_compat'D2:
  assumes "map2_val_compat' f" and "oalist_inv zs"
  shows "snd (f zs) = snd zs"
  using assms unfolding map2_val_compat'_def by blast

lemma map2_val_compat'D3:
  assumes "map2_val_compat' f" and "oalist_inv zs"
  shows "fst ` set (fst (f zs))  fst ` set (fst zs)"
  using assms unfolding map2_val_compat'_def by blast

lemma map2_val_compat'_map_val_raw: "map2_val_compat' (map_val_raw f)"
proof (rule map2_val_compat'I, erule oalist_inv_map_val_raw)
  fix zs::"('a, 'b, 'o) oalist_raw"
  obtain zs' ko where "zs = (zs', ko)" by fastforce
  thus "snd (map_val_raw f zs) = snd zs" by simp
next
  fix zs::"('a, 'b, 'o) oalist_raw"
  obtain zs' ko where zs: "zs = (zs', ko)" by fastforce
  show "fst ` set (fst (map_val_raw f zs))  fst ` set (fst zs)"
  proof (simp add: zs)
    from map_pair_subset have "fst ` set (map_val_pair f zs')  fst ` (λ(k, v). (k, f k v)) ` set zs'"
      by (rule image_mono)
    also have "... = fst ` set zs'" by force
    finally show "fst ` set (map_val_pair f zs')  fst ` set zs'" .
  qed
qed

lemma map2_val_compat'_id: "map2_val_compat' id"
  by (rule map2_val_compat'I, auto)

lemma map2_val_compat'_imp_map2_val_compat:
  assumes "map2_val_compat' g"
  shows "map2_val_compat ko (λzs. fst (g (zs, ko)))"
proof (rule map2_val_compatI)
  fix zs::"('a × 'b) list"
  assume a: "oalist_inv_raw ko zs"
  hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
  with assms have "oalist_inv (g (zs, ko))" by (rule map2_val_compat'D1)
  hence "oalist_inv (fst (g (zs, ko)), snd (g (zs, ko)))" by simp
  thus "oalist_inv_raw ko (fst (g (zs, ko)))" using assms a by (simp add: oalist_inv_alt map2_val_compat'D2)
next
  fix zs::"('a × 'b) list"
  assume a: "oalist_inv_raw ko zs"
  hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
  with assms have "fst ` set (fst (g (zs, ko)))  fst ` set (fst (zs, ko))" by (rule map2_val_compat'D3)
  thus "fst ` set (fst (g (zs, ko)))  fst ` set zs" by simp
qed

lemma oalist_inv_map2_val_raw:
  assumes "oalist_inv xs" and "oalist_inv ys"
  assumes "map2_val_compat' g" and "map2_val_compat' h"
  shows "oalist_inv (map2_val_raw f g h xs ys)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  let ?ys = "sort_oalist_aux ox ys"
  from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
  moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)"
    by (rule oalist_inv_raw_sort_oalist_aux)
  moreover from assms(3) have "map2_val_compat ko (λzs. fst (g (zs, ko)))" for ko
    by (rule map2_val_compat'_imp_map2_val_compat)
  moreover from assms(4) have "map2_val_compat ko (λzs. fst (h (zs, ko)))" for ko
    by (rule map2_val_compat'_imp_map2_val_compat)
  ultimately have "oalist_inv_raw ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys)"
    by (rule oalist_inv_raw_map2_val_pair)
  thus ?thesis by (simp add: xs oalist_inv_alt)
qed

lemma lookup_raw_map2_val_raw:
  assumes "oalist_inv xs" and "oalist_inv ys"
  assumes "map2_val_compat' g" and "map2_val_compat' h"
  assumes "zs. oalist_inv zs  g zs = map_val_raw (λk v. f k v 0) zs"
    and "zs. oalist_inv zs  h zs = map_val_raw (λk. f k 0) zs"
    and "k. f k 0 0 = 0"
  shows "lookup_raw (map2_val_raw f g h xs ys) k0 = f k0 (lookup_raw xs k0) (lookup_raw ys k0)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  let ?ys = "sort_oalist_aux ox ys"
  from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
  moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)" by (rule oalist_inv_raw_sort_oalist_aux)
  moreover from assms(3) have "map2_val_compat ko (λzs. fst (g (zs, ko)))" for ko
    by (rule map2_val_compat'_imp_map2_val_compat)
  moreover from assms(4) have "map2_val_compat ko (λzs. fst (h (zs, ko)))" for ko
    by (rule map2_val_compat'_imp_map2_val_compat)
  ultimately have "lookup_pair ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys) k0 =
                      f k0 (lookup_pair ox xs' k0) (lookup_pair ox ?ys k0)" using _ _ assms(7)
  proof (rule lookup_pair_map2_val_pair)
    fix zs::"('a × 'b) list"
    assume "oalist_inv_raw ox zs"
    hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
    hence "g (zs, ox) = map_val_raw (λk v. f k v 0) (zs, ox)" by (rule assms(5))
    thus "fst (g (zs, ox)) = map_val_pair (λk v. f k v 0) zs" by simp
  next
    fix zs::"('a × 'c) list"
    assume "oalist_inv_raw ox zs"
    hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
    hence "h (zs, ox) = map_val_raw (λk. f k 0) (zs, ox)" by (rule assms(6))
    thus "fst (h (zs, ox)) = map_val_pair (λk. f k 0) zs" by simp
  qed
  also from assms(2) have "... = f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)"
    by (simp only: lookup_pair_sort_oalist_aux)
  finally have *: "lookup_pair ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys) k0 =
                    f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)" .
  thus ?thesis by (simp add: xs)
qed

lemma map2_val_raw_singleton_eq_update_by_fun_raw:
  assumes "oalist_inv xs"
  assumes "k x. f k x 0 = x" and "zs. oalist_inv zs  g zs = zs"
    and "ko. h ([(k, v)], ko) = map_val_raw (λk. f k 0) ([(k, v)], ko)"
  shows "map2_val_raw f g h xs ([(k, v)], ko) = update_by_fun_raw k (λx. f k x v) xs"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  let ?ys = "sort_oalist ox [(k, v)]"
  from assms(1) have inv: "oalist_inv (xs', ox)" by (simp only: xs)
  hence inv_raw: "oalist_inv_raw ox xs'" by (simp only: oalist_inv_alt)
  show ?thesis
  proof (simp add: xs, intro conjI impI)
    assume "ox = ko"
    from inv_raw have "oalist_inv_raw ko xs'" by (simp only: ox = ko)
    thus "map2_val_pair ko f (λzs. fst (g (zs, ko))) (λzs. fst (h (zs, ko))) xs' [(k, v)] =
              update_by_fun_pair ko k (λx. f k x v) xs'"
      using assms(2)
    proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
      fix zs::"('a × 'b) list"
      assume "oalist_inv_raw ko zs"
      hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
      hence "g (zs, ko) = (zs, ko)" by (rule assms(3))
      thus "fst (g (zs, ko)) = zs" by simp
    next
      show "fst (h ([(k, v)], ko)) = map_val_pair (λk. f k 0) [(k, v)]" by (simp add: assms(4))
    qed
  next
    show "map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' (sort_oalist ox [(k, v)]) =
          update_by_fun_pair ox k (λx. f k x v) xs'"
    proof (cases "v = 0")
      case True
      have eq1: "sort_oalist ox [(k, 0)] = []" by (simp add: sort_oalist_def)
      from inv have eq2: "g (xs', ox) = (xs', ox)" by (rule assms(3))
      show ?thesis
        by (simp add: True eq1 eq2 assms(2) update_by_fun_pair_eq_update_by_pair[OF inv_raw],
            rule HOL.sym, rule update_by_pair_id, fact inv_raw, fact HOL.refl)
    next
      case False
      hence "oalist_inv_raw ox [(k, v)]" by (simp add: oalist_inv_raw_singleton)
      hence eq: "sort_oalist ox [(k, v)] = [(k, v)]" by (rule sort_oalist_id)
      show ?thesis unfolding eq using inv_raw assms(2)
      proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
        fix zs::"('a × 'b) list"
        assume "oalist_inv_raw ox zs"
        hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
        hence "g (zs, ox) = (zs, ox)" by (rule assms(3))
        thus "fst (g (zs, ox)) = zs" by simp
      next
        show "fst (h ([(k, v)], ox)) = map_val_pair (λk. f k 0) [(k, v)]" by (simp add: assms(4))
      qed
    qed
  qed
qed

subsubsection @{const lex_ord_raw}

lemma lex_ord_raw_EqI:
  assumes "oalist_inv xs" and "oalist_inv ys"
    and "k. k  fst ` set (fst xs)  fst ` set (fst ys)  f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
  shows "lex_ord_raw ko f xs ys = Some Eq"
  unfolding lex_ord_raw_def
  by (rule lex_ord_pair_EqI, simp_all add: assms oalist_inv_raw_sort_oalist_aux lookup_pair_sort_oalist_aux set_sort_oalist_aux)

lemma lex_ord_raw_valI:
  assumes "oalist_inv xs" and "oalist_inv ys" and "aux  Some Eq"
  assumes "k  fst ` set (fst xs)  fst ` set (fst ys)" and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
    and "k'. k'  fst ` set (fst xs)  fst ` set (fst ys)  lt ko k' k 
              f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
  shows "lex_ord_raw ko f xs ys = aux"
  unfolding lex_ord_raw_def
  using oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_raw_sort_oalist_aux[OF assms(2)] assms(3)
  unfolding oalist_inv_alt
proof (rule lex_ord_pair_valI)
  from assms(1, 2, 4) show "k  fst ` set (sort_oalist_aux ko xs)  fst ` set (sort_oalist_aux ko ys)"
    by (simp add: set_sort_oalist_aux)
next
  from assms(1, 2, 5) show "aux = f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k)"
    by (simp add: lookup_pair_sort_oalist_aux)
next
  fix k'
  assume "k'  fst ` set (sort_oalist_aux ko xs)  fst ` set (sort_oalist_aux ko ys)"
  with assms(1, 2) have "k'  fst ` set (fst xs)  fst ` set (fst ys)" by (simp add: set_sort_oalist_aux)
  moreover assume "lt ko k' k"
  ultimately have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq" by (rule assms(6))
  with assms(1, 2) show "f k' (lookup_pair ko (sort_oalist_aux ko xs) k') (lookup_pair ko (sort_oalist_aux ko ys) k') = Some Eq"
    by (simp add: lookup_pair_sort_oalist_aux)
qed

lemma lex_ord_raw_EqD:
  assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = Some Eq"
    and "k  fst ` set (fst xs)  fst ` set (fst ys)"
  shows "f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
proof -
  have "f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k) = Some Eq"
    by (rule lex_ord_pair_EqD[where f=f],
        simp_all add: oalist_inv_raw_sort_oalist_aux assms lex_ord_raw_def[symmetric] set_sort_oalist_aux del: Un_iff)
  with assms(1, 2) show ?thesis by (simp add: lookup_pair_sort_oalist_aux)
qed

lemma lex_ord_raw_valE:
  assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = aux"
    and "aux  Some Eq"
  obtains k where "k  fst ` set (fst xs)  fst ` set (fst ys)"
    and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
    and "k'. k'  fst ` set (fst xs)  fst ` set (fst ys)  lt ko k' k 
            f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
proof -
  let ?xs = "sort_oalist_aux ko xs"
  let ?ys = "sort_oalist_aux ko ys"
  from assms(3) have "lex_ord_pair ko f ?xs ?ys = aux" by (simp only: lex_ord_raw_def)
  with oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_sort_oalist_aux[OF assms(2)]
  obtain k where a: "k  fst ` set ?xs  fst ` set ?ys"
    and b: "aux = f k (lookup_pair ko ?xs k) (lookup_pair ko ?ys k)"
    and c: "k'. k'  fst ` set ?xs  fst ` set ?ys  lt ko k' k 
            f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k') = Some Eq"
    using assms(4) unfolding oalist_inv_alt by (rule lex_ord_pair_valE, blast)
  from a have "k  fst ` set (fst xs)  fst ` set (fst ys)"
    by (simp add: set_sort_oalist_aux assms(1, 2))
  moreover from b have "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
    by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
  moreover have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
    if k'_in: "k'  fst ` set (fst xs)  fst ` set (fst ys)" and k'_less: "lt ko k' k" for k'
  proof -
    have "f k' (lookup_raw xs k') (lookup_raw ys k') = f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k')"
      by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
    also have "... = Some Eq"
    proof (rule c)
      from k'_in show "k'  fst ` set ?xs  fst ` set ?ys"
        by (simp add:  set_sort_oalist_aux assms(1, 2))
    next
      from k'_less show "lt ko k' k" by (simp only: lt_of_key_order.rep_eq)
    qed
    finally show ?thesis .
  qed
  ultimately show ?thesis ..
qed

subsubsection @{const prod_ord_raw}

lemma prod_ord_rawI:
  assumes "oalist_inv xs" and "oalist_inv ys"
    and "k. k  fst ` set (fst xs)  fst ` set (fst ys)  P k (lookup_raw xs k) (lookup_raw ys k)"
  shows "prod_ord_raw P xs ys"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
  hence *: "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" using oalist_inv_raw_sort_oalist_aux
  proof (rule prod_ord_pairI)
    fix k
    assume "k  fst ` set xs'  fst ` set (sort_oalist_aux ox ys)"
    hence "k  fst ` set (fst xs)  fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
    hence "P k (lookup_raw xs k) (lookup_raw ys k)" by (rule assms(3))
    thus "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
      by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
  qed fact
  thus ?thesis by (simp add: xs)
qed

lemma prod_ord_rawD:
  assumes "oalist_inv xs" and "oalist_inv ys" and "prod_ord_raw P xs ys"
    and "k  fst ` set (fst xs)  fst ` set (fst ys)"
  shows "P k (lookup_raw xs k) (lookup_raw ys k)"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
  moreover note oalist_inv_raw_sort_oalist_aux[OF assms(2)]
  moreover from assms(3) have "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" by (simp add: xs)
  moreover from assms(4) have "k  fst ` set xs'  fst ` set (sort_oalist_aux ox ys)"
    by (simp add: xs set_sort_oalist_aux assms(2))
  ultimately have *: "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
    by (rule prod_ord_pairD)
  thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
qed

corollary prod_ord_raw_alt:
  assumes "oalist_inv xs" and "oalist_inv ys"
  shows "prod_ord_raw P xs ys 
          (kfst ` set (fst xs)  fst ` set (fst ys). P k (lookup_raw xs k) (lookup_raw ys k))"
  using prod_ord_rawI[OF assms] prod_ord_rawD[OF assms] by meson

subsubsection @{const oalist_eq_raw}

lemma oalist_eq_rawI:
  assumes "oalist_inv xs" and "oalist_inv ys"
    and "k. k  fst ` set (fst xs)  fst ` set (fst ys)  lookup_raw xs k = lookup_raw ys k"
  shows "oalist_eq_raw xs ys"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
  hence *: "xs' = sort_oalist_aux ox ys" using oalist_inv_raw_sort_oalist_aux[OF assms(2)]
  proof (rule lookup_pair_inj)
    show "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)"
    proof
      fix k
      show "lookup_pair ox xs' k = lookup_pair ox (sort_oalist_aux ox ys) k"
      proof (cases "k  fst ` set xs'  fst ` set (sort_oalist_aux ox ys)")
        case True
        hence "k  fst ` set (fst xs)  fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
        hence "lookup_raw xs k = lookup_raw ys k" by (rule assms(3))
        thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
      next
        case False
        hence "k  fst ` set xs'" and "k  fst ` set (sort_oalist_aux ox ys)" by simp_all
        with ‹oalist_inv_raw ox xs' oalist_inv_raw_sort_oalist_aux[OF assms(2)]
        have "lookup_pair ox xs' k = 0" and "lookup_pair ox (sort_oalist_aux ox ys) k = 0"
          by (simp_all add: lookup_pair_eq_0)
        thus ?thesis by simp
      qed
    qed
  qed
  thus ?thesis by (simp add: xs)
qed

lemma oalist_eq_rawD:
  assumes "oalist_inv ys" and "oalist_eq_raw xs ys"
  shows "lookup_raw xs = lookup_raw ys"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms(2) have "xs' = sort_oalist_aux ox ys" by (simp add: xs)
  hence "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)" by simp
  thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(1))
qed

lemma oalist_eq_raw_alt:
  assumes "oalist_inv xs" and "oalist_inv ys"
  shows "oalist_eq_raw xs ys  (lookup_raw xs = lookup_raw ys)"
  using oalist_eq_rawI[OF assms] oalist_eq_rawD[OF assms(2)] by metis

subsubsection @{const sort_oalist_raw}

lemma oalist_inv_sort_oalist_raw: "oalist_inv (sort_oalist_raw xs)"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  show ?thesis by (simp add: xs oalist_inv_raw_sort_oalist oalist_inv_alt)
qed

lemma sort_oalist_raw_id:
  assumes "oalist_inv xs"
  shows "sort_oalist_raw xs = xs"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
  hence "sort_oalist ko xs' = xs'" by (rule sort_oalist_id)
  thus ?thesis by (simp add: xs)
qed

lemma set_sort_oalist_raw:
  assumes "distinct (map fst (fst xs))"
  shows "set (fst (sort_oalist_raw xs)) = {kv. kv  set (fst xs)  snd kv  0}"
proof -
  obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
  from assms have "distinct (map fst xs')" by (simp add: xs)
  hence "set (sort_oalist ko xs') = {kv  set xs'. snd kv  0}" by (rule set_sort_oalist)
  thus ?thesis by (simp add: xs)
qed

end (* oalist_raw *)

subsection ‹Fundamental Operations on One List›

locale oalist_abstract = oalist_raw rep_key_order for rep_key_order::"'o  'a key_order" +
  fixes list_of_oalist :: "'x  ('a, 'b::zero, 'o) oalist_raw"
  fixes oalist_of_list :: "('a, 'b, 'o) oalist_raw  'x"
  assumes oalist_inv_list_of_oalist: "oalist_inv (list_of_oalist x)"
  and list_of_oalist_of_list: "list_of_oalist (oalist_of_list xs) = sort_oalist_raw xs"
  and oalist_of_list_of_oalist: "oalist_of_list (list_of_oalist x) = x"
begin

lemma list_of_oalist_of_list_id:
  assumes "oalist_inv xs"
  shows "list_of_oalist (oalist_of_list xs) = xs"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  from assms show ?thesis by (simp add: xs list_of_oalist_of_list sort_oalist_id oalist_inv_alt)
qed

definition lookup :: "'x  'a  'b"
  where "lookup xs = lookup_raw (list_of_oalist xs)"

definition sorted_domain :: "'o  'x  'a list"
  where "sorted_domain ko xs = sorted_domain_raw ko (list_of_oalist xs)"

definition empty :: "'o  'x"
  where "empty ko = oalist_of_list ([], ko)"

definition reorder :: "'o  'x  'x"
  where "reorder ko xs = oalist_of_list (sort_oalist_aux ko (list_of_oalist xs), ko)"

definition tl :: "'x  'x"
  where "tl xs = oalist_of_list (tl_raw (list_of_oalist xs))"

definition hd :: "'x  ('a × 'b)"
  where "hd xs = List.hd (fst (list_of_oalist xs))"

definition except_min :: "'o  'x  'x"
  where "except_min ko xs = tl (reorder ko xs)"

definition min_key_val :: "'o  'x  ('a × 'b)"
  where "min_key_val ko xs = min_key_val_raw ko (list_of_oalist xs)"

definition insert :: "('a × 'b)  'x  'x"
  where "insert x xs = oalist_of_list (update_by_raw x (list_of_oalist xs))"

definition update_by_fun :: "'a  ('b  'b)  'x  'x"
  where "update_by_fun k f xs = oalist_of_list (update_by_fun_raw k f (list_of_oalist xs))"

definition update_by_fun_gr :: "'a  ('b  'b)  'x  'x"
  where "update_by_fun_gr k f xs = oalist_of_list (update_by_fun_gr_raw k f (list_of_oalist xs))"

definition filter :: "(('a × 'b)  bool)  'x  'x"
  where "filter P xs = oalist_of_list (filter_raw P (list_of_oalist xs))"

definition map2_val_neutr :: "('a  'b  'b  'b)  'x  'x  'x"
  where "map2_val_neutr f xs ys = oalist_of_list (map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys))"

definition oalist_eq :: "'x  'x  bool"
  where "oalist_eq xs ys = oalist_eq_raw (list_of_oalist xs) (list_of_oalist ys)"

subsubsection ‹Invariant›

lemma zero_notin_list_of_oalist: "0  snd ` set (fst (list_of_oalist xs))"
proof -
  from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
    by (simp only: oalist_inv_def)
  thus ?thesis by (rule oalist_inv_rawD1)
qed

lemma list_of_oalist_sorted: "sorted_wrt (lt (snd (list_of_oalist xs))) (map fst (fst (list_of_oalist xs)))"
proof -
  from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
    by (simp only: oalist_inv_def)
  thus ?thesis by (rule oalist_inv_rawD2)
qed

subsubsection @{const lookup}

lemma lookup_eq_value: "v  0  lookup xs k = v  ((k, v)  set (fst (list_of_oalist xs)))"
  unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_value)

lemma lookup_eq_valueI: "(k, v)  set (fst (list_of_oalist xs))  lookup xs k = v"
  unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_valueI)

lemma lookup_oalist_of_list:
  "distinct (map fst xs)  lookup (oalist_of_list (xs, ko)) = lookup_dflt xs"
  by (simp add: list_of_oalist_of_list lookup_def lookup_pair_sort_oalist')

subsubsection @{const sorted_domain}

lemma set_sorted_domain: "set (sorted_domain ko xs) = fst ` set (fst (list_of_oalist xs))"
  unfolding sorted_domain_def using oalist_inv_list_of_oalist by (rule set_sorted_domain_raw)

lemma in_sorted_domain_iff_lookup: "k  set (sorted_domain ko xs)  (lookup xs k  0)"
  unfolding sorted_domain_def lookup_def using oalist_inv_list_of_oalist
  by (rule in_sorted_domain_raw_iff_lookup_raw)

lemma sorted_sorted_domain: "sorted_wrt (lt ko) (sorted_domain ko xs)"
  unfolding sorted_domain_def lt_of_key_order.rep_eq[symmetric]
  using oalist_inv_list_of_oalist by (rule sorted_sorted_domain_raw)

subsubsection @{const empty} and Singletons›

lemma list_of_oalist_empty [simp, code abstract]: "list_of_oalist (empty ko) = ([], ko)"
  by (simp add: empty_def sort_oalist_def list_of_oalist_of_list)

lemma lookup_empty: "lookup (empty ko) k = 0"
  by (simp add: lookup_def)

lemma lookup_oalist_of_list_single:
  "lookup (oalist_of_list ([(k, v)], ko)) k' = (if k = k' then v else 0)"
  by (simp add: lookup_def list_of_oalist_of_list sort_oalist_def key_compare_Eq split: order.split)

subsubsection @{const reorder}

lemma list_of_oalist_reorder [simp, code abstract]:
  "list_of_oalist (reorder ko xs) = (sort_oalist_aux ko (list_of_oalist xs), ko)"
  unfolding reorder_def
  by (rule list_of_oalist_of_list_id, simp add: oalist_inv_def, rule oalist_inv_raw_sort_oalist_aux, fact oalist_inv_list_of_oalist)

lemma lookup_reorder: "lookup (reorder ko xs) k = lookup xs k"
  by (simp add: lookup_def lookup_pair_sort_oalist_aux oalist_inv_list_of_oalist)

subsubsection @{const hd} and @{const tl}

lemma list_of_oalist_tl [simp, code abstract]: "list_of_oalist (tl xs) = tl_raw (list_of_oalist xs)"
  unfolding tl_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_tl_raw, fact oalist_inv_list_of_oalist)

lemma lookup_tl:
  "lookup (tl xs) k =
        (if (k'fst ` set (fst (list_of_oalist xs)). le (snd (list_of_oalist xs)) k k') then 0 else lookup xs k)"
  by (simp add: lookup_def lookup_raw_tl_raw oalist_inv_list_of_oalist)

lemma hd_in:
  assumes "fst (list_of_oalist xs)  []"
  shows "hd xs  set (fst (list_of_oalist xs))"
  unfolding hd_def using assms by (rule hd_in_set)

lemma snd_hd:
  assumes "fst (list_of_oalist xs)  []"
  shows "snd (hd xs) = lookup xs (fst (hd xs))"
proof -
  from assms have *: "hd xs  set (fst (list_of_oalist xs))" by (rule hd_in)
  show ?thesis by (rule HOL.sym, rule lookup_eq_valueI, simp add: *)
qed

lemma lookup_tl': "lookup (tl xs) k = (if k = fst (hd xs) then 0 else lookup xs k)"
  by (simp add: lookup_def lookup_raw_tl_raw' oalist_inv_list_of_oalist hd_def)

lemma hd_tl:
  assumes "fst (list_of_oalist xs)  []"
  shows "list_of_oalist xs = ((hd xs) # (fst (list_of_oalist (tl xs))), snd (list_of_oalist (tl xs)))"
proof -
  obtain xs' ko where xs: "list_of_oalist xs = (xs', ko)" by fastforce
  from assms obtain x xs'' where xs': "xs' = x # xs''" unfolding xs fst_conv using list.exhaust by blast
  show ?thesis by (simp add: xs xs' hd_def)
qed

subsubsection @{const min_key_val}

lemma min_key_val_alt:
  assumes "fst (list_of_oalist xs)  []"
  shows "min_key_val ko xs = hd (reorder ko xs)"
  using assms oalist_inv_list_of_oalist by (simp add: min_key_val_def hd_def min_key_val_raw_alt)

lemma min_key_val_in:
  assumes "fst (list_of_oalist xs)  []"
  shows "min_key_val ko xs  set (fst (list_of_oalist xs))"
  unfolding min_key_val_def using assms by (rule min_key_val_raw_in)

lemma snd_min_key_val:
  assumes "fst (list_of_oalist xs)  []"
  shows "snd (min_key_val ko xs) = lookup xs (fst (min_key_val ko xs))"
  unfolding lookup_def min_key_val_def using oalist_inv_list_of_oalist assms by (rule snd_min_key_val_raw)

lemma min_key_val_minimal:
  assumes "z  set (fst (list_of_oalist xs))"
  shows "le ko (fst (min_key_val ko xs)) (fst z)"
  unfolding min_key_val_def
  by (rule min_key_val_raw_minimal, fact oalist_inv_list_of_oalist, fact)

subsubsection @{const except_min}

lemma list_of_oalist_except_min [simp, code abstract]:
  "list_of_oalist (except_min ko xs) = (List.tl (sort_oalist_aux ko (list_of_oalist xs)), ko)"
  by (simp add: except_min_def)

lemma except_min_Nil:
  assumes "fst (list_of_oalist xs) = []"
  shows "fst (list_of_oalist (except_min ko xs)) = []"
proof -
  obtain xs' ox where eq: "list_of_oalist xs = (xs', ox)" by fastforce
  from assms have "xs' = []" by (simp add: eq)
  show ?thesis by (simp add: eq xs' = [] sort_oalist_def)
qed

lemma lookup_except_min:
  "lookup (except_min ko xs) k =
        (if (k'fst ` set (fst (list_of_oalist xs)). le ko k k') then 0 else lookup xs k)"
  by (simp add: except_min_def lookup_tl set_sort_oalist_aux oalist_inv_list_of_oalist lookup_reorder)

lemma lookup_except_min':
  "lookup (except_min ko xs) k = (if k = fst (min_key_val ko xs) then 0 else lookup xs k)"
proof (cases "fst (list_of_oalist xs) = []")
  case True
  hence "lookup xs k = 0" by (metis empty_def lookup_empty oalist_of_list_of_oalist prod.collapse)
  thus ?thesis by (simp add: lookup_except_min True)
next
  case False
  thus ?thesis by (simp add: except_min_def lookup_tl' min_key_val_alt lookup_reorder)
qed

subsubsection @{const insert}

lemma list_of_oalist_insert [simp, code abstract]:
  "list_of_oalist (insert x xs) = update_by_raw x (list_of_oalist xs)"
  unfolding insert_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_raw, fact oalist_inv_list_of_oalist)

lemma lookup_insert: "lookup (insert (k, v) xs) k' = (if k = k' then v else lookup xs k')"
  by (simp add: lookup_def lookup_raw_update_by_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)

subsubsection @{const update_by_fun} and @{const update_by_fun_gr}

lemma list_of_oalist_update_by_fun [simp, code abstract]:
  "list_of_oalist (update_by_fun k f xs) = update_by_fun_raw k f (list_of_oalist xs)"
  unfolding update_by_fun_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_raw, fact oalist_inv_list_of_oalist)

lemma lookup_update_by_fun:
  "lookup (update_by_fun k f xs) k' = (if k = k' then f else id) (lookup xs k')"
  by (simp add: lookup_def lookup_raw_update_by_fun_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)

lemma list_of_oalist_update_by_fun_gr [simp, code abstract]:
  "list_of_oalist (update_by_fun_gr k f xs) = update_by_fun_gr_raw k f (list_of_oalist xs)"
  unfolding update_by_fun_gr_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_gr_raw, fact oalist_inv_list_of_oalist)

lemma update_by_fun_gr_eq_update_by_fun: "update_by_fun_gr = update_by_fun"
  by (rule, rule, rule,
      simp add: update_by_fun_gr_def update_by_fun_def update_by_fun_gr_raw_eq_update_by_fun_raw oalist_inv_list_of_oalist)

subsubsection @{const filter}

lemma list_of_oalist_filter [simp, code abstract]:
  "list_of_oalist (filter P xs) = filter_raw P (list_of_oalist xs)"
  unfolding filter_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_filter_raw, fact oalist_inv_list_of_oalist)

lemma lookup_filter: "lookup (filter P xs) k = (let v = lookup xs k in if P (k, v) then v else 0)"
  by (simp add: lookup_def lookup_raw_filter_raw oalist_inv_list_of_oalist)

subsubsection @{const map2_val_neutr}

lemma list_of_oalist_map2_val_neutr [simp, code abstract]:
  "list_of_oalist (map2_val_neutr f xs ys) = map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys)"
  unfolding map2_val_neutr_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
      fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
      fact map2_val_compat'_id, fact map2_val_compat'_id)

lemma lookup_map2_val_neutr:
  assumes "k x. f k x 0 = x" and "k x. f k 0 x = x"
  shows "lookup (map2_val_neutr f xs ys) k = f k (lookup xs k) (lookup ys k)"
proof (simp add: lookup_def, rule lookup_raw_map2_val_raw)
  fix zs::"('a, 'b, 'o) oalist_raw"
  assume "oalist_inv zs"
  thus "id zs = map_val_raw (λk v. f k v 0) zs" by (simp add: assms(1) map_raw_id)
next
  fix zs::"('a, 'b, 'o) oalist_raw"
  assume "oalist_inv zs"
  thus "id zs = map_val_raw (λk. f k 0) zs" by (simp add: assms(2) map_raw_id)
qed (fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
    fact map2_val_compat'_id, fact map2_val_compat'_id, simp only: assms(1))

subsubsection @{const oalist_eq}

lemma oalist_eq_alt: "oalist_eq xs ys  (lookup xs = lookup ys)"
  by (simp add: oalist_eq_def lookup_def oalist_eq_raw_alt oalist_inv_list_of_oalist)

end (* oalist_abstract *)

subsection ‹Fundamental Operations on Three Lists›

locale oalist_abstract3 =
  oalist_abstract rep_key_order list_of_oalistx oalist_of_listx +
  oay: oalist_abstract rep_key_order list_of_oalisty oalist_of_listy +
  oaz: oalist_abstract rep_key_order list_of_oalistz oalist_of_listz
  for rep_key_order :: "'o  'a key_order"
  and list_of_oalistx :: "'x  ('a, 'b::zero, 'o) oalist_raw"
  and oalist_of_listx :: "('a, 'b, 'o) oalist_raw  'x"
  and list_of_oalisty :: "'y  ('a, 'c::zero, 'o) oalist_raw"
  and oalist_of_listy :: "('a, 'c, 'o) oalist_raw  'y"
  and list_of_oalistz :: "'z  ('a, 'd::zero, 'o) oalist_raw"
  and oalist_of_listz :: "('a, 'd, 'o) oalist_raw  'z"
begin

definition map_val :: "('a  'b  'c)  'x  'y"
  where "map_val f xs = oalist_of_listy (map_val_raw f (list_of_oalistx xs))"

definition map2_val :: "('a  'b  'c  'd)  'x  'y  'z"
  where "map2_val f xs ys =
            oalist_of_listz (map2_val_raw f (map_val_raw (λk b. f k b 0)) (map_val_raw (λk. f k 0))
              (list_of_oalistx xs) (list_of_oalisty ys))"

definition map2_val_rneutr :: "('a  'b  'c  'b)  'x  'y  'x"
  where "map2_val_rneutr f xs ys =
            oalist_of_listx (map2_val_raw f id (map_val_raw (λk. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys))"

definition lex_ord :: "'o  ('a  ('b, 'c) comp_opt)  ('x, 'y) comp_opt"
  where "lex_ord ko f xs ys = lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys)"

definition prod_ord :: "('a  'b  'c  bool)  'x  'y  bool"
  where "prod_ord f xs ys = prod_ord_raw f (list_of_oalistx xs) (list_of_oalisty ys)"

subsubsection @{const map_val}

lemma map_val_cong:
  assumes "k v. (k, v)  set (fst (list_of_oalistx xs))  f k v = g k v"
  shows "map_val f xs = map_val g xs"
  unfolding map_val_def by (rule arg_cong[where f=oalist_of_listy], rule map_val_raw_cong, elim assms)

lemma list_of_oalist_map_val [simp, code abstract]:
  "list_of_oalisty (map_val f xs) = map_val_raw f (list_of_oalistx xs)"
  unfolding map_val_def
  by (rule oay.list_of_oalist_of_list_id, rule oalist_inv_map_val_raw, fact oalist_inv_list_of_oalist)

lemma lookup_map_val: "f k 0 = 0  oay.lookup (map_val f xs) k = f k (lookup xs k)"
  by (simp add: oay.lookup_def lookup_def lookup_raw_map_val_raw oalist_inv_list_of_oalist)

subsubsection @{const map2_val} and @{const map2_val_rneutr}

lemma list_of_oalist_map2_val [simp, code abstract]:
  "list_of_oalistz (map2_val f xs ys) =
      map2_val_raw f (map_val_raw (λk b. f k b 0)) (map_val_raw (λk. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys)"
  unfolding map2_val_def
  by (rule oaz.list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
      fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
      fact map2_val_compat'_map_val_raw, fact map2_val_compat'_map_val_raw)

lemma list_of_oalist_map2_val_rneutr [simp, code abstract]:
  "list_of_oalistx (map2_val_rneutr f xs ys) =
      map2_val_raw f id (map_val_raw (λk c. f k 0 c)) (list_of_oalistx xs) (list_of_oalisty ys)"
  unfolding map2_val_rneutr_def
  by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
      fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
      fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw)

lemma lookup_map2_val:
  assumes "k. f k 0 0 = 0"
  shows "oaz.lookup (map2_val f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
  by (simp add: oaz.lookup_def oay.lookup_def lookup_def lookup_raw_map2_val_raw
      map2_val_compat'_map_val_raw assms oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)

lemma lookup_map2_val_rneutr:
  assumes "k x. f k x 0 = x"
  shows "lookup (map2_val_rneutr f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
proof (simp add: lookup_def oay.lookup_def, rule lookup_raw_map2_val_raw)
  fix zs::"('a, 'b, 'o) oalist_raw"
  assume "oalist_inv zs"
  thus "id zs = map_val_raw (λk v. f k v 0) zs" by (simp add: assms map_raw_id)
qed (fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
    fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw, rule HOL.refl, simp only: assms)

lemma map2_val_rneutr_singleton_eq_update_by_fun:
  assumes "a x. f a x 0 = x" and "list_of_oalisty ys = ([(k, v)], oy)"
  shows "map2_val_rneutr f xs ys = update_by_fun k (λx. f k x v) xs"
  by (simp add: map2_val_rneutr_def update_by_fun_def assms map2_val_raw_singleton_eq_update_by_fun_raw oalist_inv_list_of_oalist)

subsubsection @{const lex_ord} and @{const prod_ord}

lemma lex_ord_EqI:
  "(k. k  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
     f k (lookup xs k) (oay.lookup ys k) = Some Eq) 
  lex_ord ko f xs ys = Some Eq"
  by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqI,
      rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, blast)

lemma lex_ord_valI:
  assumes "aux  Some Eq" and "k  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys))"
  shows "aux = f k (lookup xs k) (oay.lookup ys k) 
         (k'. k'  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
              lt ko k' k  f k' (lookup xs k') (oay.lookup ys k') = Some Eq) 
          lex_ord ko f xs ys = aux"
  by (simp (no_asm_use) add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_valI,
      rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, rule assms(1), rule assms(2), blast+)

lemma lex_ord_EqD:
  "lex_ord ko f xs ys = Some Eq 
   k  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
   f k (lookup xs k) (oay.lookup ys k) = Some Eq"
  by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqD[where f=f],
      rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, assumption, simp)

lemma lex_ord_valE:
  assumes "lex_ord ko f xs ys = aux" and "aux  Some Eq"
  obtains k where "k  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys))"
    and "aux = f k (lookup xs k) (oay.lookup ys k)"
    and "k'. k'  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
            lt ko k' k  f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
proof -
  note oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist
  moreover from assms(1) have "lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys) = aux"
    by (simp only: lex_ord_def)
  ultimately obtain k where 1: "k  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys))"
    and "aux = f k (lookup_raw (list_of_oalistx xs) k) (lookup_raw (list_of_oalisty ys) k)"
    and "k'. k'  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
            lt ko k' k 
            f k' (lookup_raw (list_of_oalistx xs) k') (lookup_raw (list_of_oalisty ys) k') = Some Eq"
    using assms(2) by (rule lex_ord_raw_valE, blast)
  from this(2, 3) have "aux = f k (lookup xs k) (oay.lookup ys k)"
    and "k'. k'  fst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)) 
            lt ko k' k  f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
    by (simp_all only: lookup_def oay.lookup_def)
  with 1 show ?thesis ..
qed

lemma prod_ord_alt:
  "prod_ord P xs ys 
                  (kfst ` set (fst (list_of_oalistx xs))  fst ` set (fst (list_of_oalisty ys)).
                      P k (lookup xs k) (oay.lookup ys k))"
  by (simp add: prod_ord_def lookup_def oay.lookup_def prod_ord_raw_alt oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)

end (* oalist_abstract3 *)

subsection ‹Type oalist›

global_interpretation ko: comparator "key_compare ko"
  defines lookup_pair_ko = ko.lookup_pair
  and update_by_pair_ko = ko.update_by_pair
  and update_by_fun_pair_ko = ko.update_by_fun_pair
  and update_by_fun_gr_pair_ko = ko.update_by_fun_gr_pair
  and map2_val_pair_ko = ko.map2_val_pair
  and lex_ord_pair_ko = ko.lex_ord_pair
  and prod_ord_pair_ko = ko.prod_ord_pair
  and sort_oalist_ko' = ko.sort_oalist
  by (fact comparator_key_compare)

lemma ko_le: "ko.le = le_of_key_order"
  by (intro ext, simp add: le_of_comp_def le_of_key_order_alt split: order.split)

global_interpretation ko: oalist_raw "λx. x"
  rewrites "comparator.lookup_pair (key_compare ko) = lookup_pair_ko ko"
  and "comparator.update_by_pair (key_compare ko) = update_by_pair_ko ko"
  and "comparator.update_by_fun_pair (key_compare ko) = update_by_fun_pair_ko ko"
  and "comparator.update_by_fun_gr_pair (key_compare ko) = update_by_fun_gr_pair_ko ko"
  and "comparator.map2_val_pair (key_compare ko) = map2_val_pair_ko ko"
  and "comparator.lex_ord_pair (key_compare ko) = lex_ord_pair_ko ko"
  and "comparator.prod_ord_pair (key_compare ko) = prod_ord_pair_ko ko"
  and "comparator.sort_oalist (key_compare ko) = sort_oalist_ko' ko"
  defines sort_oalist_aux_ko = ko.sort_oalist_aux
  and lookup_ko = ko.lookup_raw
  and sorted_domain_ko = ko.sorted_domain_raw
  and tl_ko = ko.tl_raw
  and min_key_val_ko = ko.min_key_val_raw
  and update_by_ko = ko.update_by_raw
  and update_by_fun_ko = ko.update_by_fun_raw
  and update_by_fun_gr_ko = ko.update_by_fun_gr_raw
  and map2_val_ko = ko.map2_val_raw
  and lex_ord_ko = ko.lex_ord_raw
  and prod_ord_ko = ko.prod_ord_raw
  and oalist_eq_ko = ko.oalist_eq_raw
  and sort_oalist_ko = ko.sort_oalist_raw
  subgoal by (simp only: lookup_pair_ko_def)
  subgoal by (simp only: update_by_pair_ko_def)
  subgoal by (simp only: update_by_fun_pair_ko_def)
  subgoal by (simp only: update_by_fun_gr_pair_ko_def)
  subgoal by (simp only: map2_val_pair_ko_def)
  subgoal by (simp only: lex_ord_pair_ko_def)
  subgoal by (simp only: prod_ord_pair_ko_def)
  subgoal by (simp only: sort_oalist_ko'_def)
  done

typedef (overloaded) ('a, 'b) oalist = "{xs::('a, 'b::zero, 'a key_order) oalist_raw. ko.oalist_inv xs}"
  morphisms list_of_oalist Abs_oalist
  by (auto simp: ko.oalist_inv_def intro: ko.oalist_inv_raw_Nil)

lemma oalist_eq_iff: "xs = ys  list_of_oalist xs = list_of_oalist ys"
  by (simp add: list_of_oalist_inject)

lemma oalist_eqI: "list_of_oalist xs = list_of_oalist ys  xs = ys"
  by (simp add: oalist_eq_iff)

text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist"}:›

definition OAlist :: "('a × 'b) list × 'a key_order  ('a, 'b::zero) oalist" where
  "OAlist xs = Abs_oalist (sort_oalist_ko xs)"

definition "oalist_of_list = OAlist"

lemma oalist_inv_list_of_oalist: "ko.oalist_inv (list_of_oalist xs)"
  using list_of_oalist [of xs] by simp

lemma list_of_oalist_OAlist: "list_of_oalist (OAlist xs) = sort_oalist_ko xs"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  show ?thesis by (simp add: xs OAlist_def Abs_oalist_inverse ko.oalist_inv_raw_sort_oalist ko.oalist_inv_alt)
qed

lemma OAlist_list_of_oalist [code abstype]: "OAlist (list_of_oalist xs) = xs"
proof -
  obtain xs' ox where xs: "list_of_oalist xs = (xs', ox)" by fastforce
  have "ko.oalist_inv_raw ox xs'" by (simp add: xs[symmetric] ko.oalist_inv_alt[symmetric] oalist_inv_list_of_oalist)
  thus ?thesis by (simp add: xs OAlist_def ko.sort_oalist_id, simp add: list_of_oalist_inverse xs[symmetric])
qed

lemma [code abstract]: "list_of_oalist (oalist_of_list xs) = sort_oalist_ko xs"
  by (simp add: list_of_oalist_OAlist oalist_of_list_def)

global_interpretation oa: oalist_abstract "λx. x" list_of_oalist OAlist
  defines OAlist_lookup = oa.lookup
  and OAlist_sorted_domain = oa.sorted_domain
  and OAlist_empty = oa.empty
  and OAlist_reorder = oa.reorder
  and OAlist_tl = oa.tl
  and OAlist_hd = oa.hd
  and OAlist_except_min = oa.except_min
  and OAlist_min_key_val = oa.min_key_val
  and OAlist_insert = oa.insert
  and OAlist_update_by_fun = oa.update_by_fun
  and OAlist_update_by_fun_gr = oa.update_by_fun_gr
  and OAlist_filter = oa.filter
  and OAlist_map2_val_neutr = oa.map2_val_neutr
  and OAlist_eq = oa.oalist_eq
  apply standard
  subgoal by (fact oalist_inv_list_of_oalist)
  subgoal by (simp only: list_of_oalist_OAlist sort_oalist_ko_def)
  subgoal by (fact OAlist_list_of_oalist)
  done

global_interpretation oa: oalist_abstract3 "λx. x"
    "list_of_oalist::('a, 'b) oalist  ('a, 'b::zero, 'a key_order) oalist_raw" OAlist
    "list_of_oalist::('a, 'c) oalist  ('a, 'c::zero, 'a key_order) oalist_raw" OAlist
    "list_of_oalist::('a, 'd) oalist  ('a, 'd::zero, 'a key_order) oalist_raw" OAlist
  defines OAlist_map_val = oa.map_val
  and OAlist_map2_val = oa.map2_val
  and OAlist_map2_val_rneutr = oa.map2_val_rneutr
  and OAlist_lex_ord = oa.lex_ord
  and OAlist_prod_ord = oa.prod_ord ..

lemmas OAlist_lookup_single = oa.lookup_oalist_of_list_single[folded oalist_of_list_def]

subsection ‹Type oalist_tc›

text ‹``tc'' stands for ``type class''.›

global_interpretation tc: comparator "comparator_of"
  defines lookup_pair_tc = tc.lookup_pair
  and update_by_pair_tc = tc.update_by_pair
  and update_by_fun_pair_tc = tc.update_by_fun_pair
  and update_by_fun_gr_pair_tc = tc.update_by_fun_gr_pair
  and map2_val_pair_tc = tc.map2_val_pair
  and lex_ord_pair_tc = tc.lex_ord_pair
  and prod_ord_pair_tc = tc.prod_ord_pair
  and sort_oalist_tc = tc.sort_oalist
  by (fact comparator_of)

lemma tc_le_lt [simp]: "tc.le = (≤)" "tc.lt = (<)"
  by (auto simp: le_of_comp_def lt_of_comp_def comparator_of_def intro!: ext split: order.split_asm if_split_asm)

typedef (overloaded) ('a, 'b) oalist_tc = "{xs::('a::linorder × 'b::zero) list. tc.oalist_inv_raw xs}"
  morphisms list_of_oalist_tc Abs_oalist_tc
  by (auto intro: tc.oalist_inv_raw_Nil)

lemma oalist_tc_eq_iff: "xs = ys  list_of_oalist_tc xs = list_of_oalist_tc ys"
  by (simp add: list_of_oalist_tc_inject)

lemma oalist_tc_eqI: "list_of_oalist_tc xs = list_of_oalist_tc ys  xs = ys"
  by (simp add: oalist_tc_eq_iff)

text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist_tc"}:›

definition OAlist_tc :: "('a × 'b) list  ('a::linorder, 'b::zero) oalist_tc" where
  "OAlist_tc xs = Abs_oalist_tc (sort_oalist_tc xs)"

definition "oalist_tc_of_list = OAlist_tc"

lemma oalist_inv_list_of_oalist_tc: "tc.oalist_inv_raw (list_of_oalist_tc xs)"
  using list_of_oalist_tc[of xs] by simp

lemma list_of_oalist_OAlist_tc: "list_of_oalist_tc (OAlist_tc xs) = sort_oalist_tc xs"
  by (simp add: OAlist_tc_def Abs_oalist_tc_inverse tc.oalist_inv_raw_sort_oalist)

lemma OAlist_list_of_oalist_tc [code abstype]: "OAlist_tc (list_of_oalist_tc xs) = xs"
  by (simp add: OAlist_tc_def tc.sort_oalist_id list_of_oalist_tc_inverse oalist_inv_list_of_oalist_tc)

lemma list_of_oalist_tc_of_list [code abstract]: "list_of_oalist_tc (oalist_tc_of_list xs) = sort_oalist_tc xs"
  by (simp add: list_of_oalist_OAlist_tc oalist_tc_of_list_def)

lemma list_of_oalist_tc_of_list_id:
  assumes "tc.oalist_inv_raw xs"
  shows "list_of_oalist_tc (OAlist_tc xs) = xs"
  using assms by (simp add: list_of_oalist_OAlist_tc tc.sort_oalist_id)

text ‹It is better to define the following operations directly instead of interpreting
  @{locale oalist_abstract}, because @{locale oalist_abstract} defines the operations via their
  _raw› analogues, whereas in this case we can define them directly via their _pair› analogues.›

definition OAlist_tc_lookup :: "('a::linorder, 'b::zero) oalist_tc  'a  'b"
  where "OAlist_tc_lookup xs = lookup_pair_tc (list_of_oalist_tc xs)"

definition OAlist_tc_sorted_domain :: "('a::linorder, 'b::zero) oalist_tc  'a list"
  where "OAlist_tc_sorted_domain xs = map fst (list_of_oalist_tc xs)"

definition OAlist_tc_empty :: "('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_empty = OAlist_tc []"

definition OAlist_tc_except_min :: "('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_except_min xs = OAlist_tc (tl (list_of_oalist_tc xs))"

definition OAlist_tc_min_key_val :: "('a::linorder, 'b::zero) oalist_tc  ('a × 'b)"
  where "OAlist_tc_min_key_val xs = hd (list_of_oalist_tc xs)"

definition OAlist_tc_insert :: "('a × 'b)  ('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_insert x xs = OAlist_tc (update_by_pair_tc x (list_of_oalist_tc xs))"

definition OAlist_tc_update_by_fun :: "'a  ('b  'b)  ('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_update_by_fun k f xs = OAlist_tc (update_by_fun_pair_tc k f (list_of_oalist_tc xs))"

definition OAlist_tc_update_by_fun_gr :: "'a  ('b  'b)  ('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_update_by_fun_gr k f xs = OAlist_tc (update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs))"

definition OAlist_tc_filter :: "(('a × 'b)  bool)  ('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_filter P xs = OAlist_tc (filter P (list_of_oalist_tc xs))"

definition OAlist_tc_map_val :: "('a  'b  'c)  ('a, 'b::zero) oalist_tc  ('a::linorder, 'c::zero) oalist_tc"
  where "OAlist_tc_map_val f xs = OAlist_tc (map_val_pair f (list_of_oalist_tc xs))"

definition OAlist_tc_map2_val :: "('a  'b  'c  'd)  ('a, 'b::zero) oalist_tc  ('a, 'c::zero) oalist_tc 
                                    ('a::linorder, 'd::zero) oalist_tc"
  where "OAlist_tc_map2_val f xs ys =
            OAlist_tc (map2_val_pair_tc f (map_val_pair (λk b. f k b 0)) (map_val_pair (λk. f k 0))
              (list_of_oalist_tc xs) (list_of_oalist_tc ys))"

definition OAlist_tc_map2_val_rneutr :: "('a  'b  'c  'b)  ('a, 'b) oalist_tc  ('a, 'c::zero) oalist_tc 
                                    ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_map2_val_rneutr f xs ys =
            OAlist_tc (map2_val_pair_tc f id (map_val_pair (λk. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys))"

definition OAlist_tc_map2_val_neutr :: "('a  'b  'b  'b)  ('a, 'b) oalist_tc 
                                          ('a, 'b) oalist_tc  ('a::linorder, 'b::zero) oalist_tc"
  where "OAlist_tc_map2_val_neutr f xs ys = OAlist_tc (map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys))"

definition OAlist_tc_lex_ord :: "('a  ('b, 'c) comp_opt)  (('a, 'b::zero) oalist_tc, ('a::linorder, 'c::zero) oalist_tc) comp_opt"
  where "OAlist_tc_lex_ord f xs ys = lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"

definition OAlist_tc_prod_ord :: "('a  'b  'c  bool)  ('a, 'b::zero) oalist_tc  ('a::linorder, 'c::zero) oalist_tc  bool"
  where "OAlist_tc_prod_ord f xs ys = prod_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"

subsubsection @{const OAlist_tc_lookup}

lemma OAlist_tc_lookup_eq_valueI: "(k, v)  set (list_of_oalist_tc xs)  OAlist_tc_lookup xs k = v"
  unfolding OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc by (rule tc.lookup_pair_eq_valueI)

lemma OAlist_tc_lookup_inj: "OAlist_tc_lookup xs = OAlist_tc_lookup ys  xs = ys"
  by (simp add: OAlist_tc_lookup_def oalist_inv_list_of_oalist_tc oalist_tc_eqI tc.lookup_pair_inj)

lemma OAlist_tc_lookup_oalist_of_list:
  "distinct (map fst xs)  OAlist_tc_lookup (oalist_tc_of_list xs) = lookup_dflt xs"
  by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.lookup_pair_sort_oalist')

subsubsection @{const OAlist_tc_sorted_domain}

lemma set_OAlist_tc_sorted_domain: "set (OAlist_tc_sorted_domain xs) = fst ` set (list_of_oalist_tc xs)"
  unfolding OAlist_tc_sorted_domain_def by simp

lemma in_OAlist_tc_sorted_domain_iff_lookup: "k  set (OAlist_tc_sorted_domain xs)  (OAlist_tc_lookup xs k  0)"
  unfolding OAlist_tc_sorted_domain_def OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc tc.lookup_pair_eq_0
  by fastforce

lemma sorted_OAlist_tc_sorted_domain: "sorted_wrt (<) (OAlist_tc_sorted_domain xs)"
  unfolding OAlist_tc_sorted_domain_def tc_le_lt[symmetric] using oalist_inv_list_of_oalist_tc
  by (rule tc.oalist_inv_rawD2)

subsubsection @{const OAlist_tc_empty} and Singletons›

lemma list_of_oalist_OAlist_tc_empty [simp, code abstract]: "list_of_oalist_tc OAlist_tc_empty = []"
  unfolding OAlist_tc_empty_def using tc.oalist_inv_raw_Nil by (rule list_of_oalist_tc_of_list_id)

lemma lookup_OAlist_tc_empty: "OAlist_tc_lookup OAlist_tc_empty k = 0"
  by (simp add: OAlist_tc_lookup_def)

lemma OAlist_tc_lookup_single:
  "OAlist_tc_lookup (oalist_tc_of_list [(k, v)]) k' = (if k = k' then v else 0)"
  by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.sort_oalist_def comparator_of_def split: order.split)

subsubsection @{const OAlist_tc_except_min}

lemma list_of_oalist_OAlist_tc_except_min [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_except_min xs) = tl (list_of_oalist_tc xs)"
  unfolding OAlist_tc_except_min_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_tl, fact oalist_inv_list_of_oalist_tc)

lemma lookup_OAlist_tc_except_min:
  "OAlist_tc_lookup (OAlist_tc_except_min xs) k =
        (if (k'fst ` set (list_of_oalist_tc xs). k  k') then 0 else OAlist_tc_lookup xs k)"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_tl oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)

subsubsection @{const OAlist_tc_min_key_val}

lemma OAlist_tc_min_key_val_in:
  assumes "list_of_oalist_tc xs  []"
  shows "OAlist_tc_min_key_val xs  set (list_of_oalist_tc xs)"
  unfolding OAlist_tc_min_key_val_def using assms by simp

lemma snd_OAlist_tc_min_key_val:
  assumes "list_of_oalist_tc xs  []"
  shows "snd (OAlist_tc_min_key_val xs) = OAlist_tc_lookup xs (fst (OAlist_tc_min_key_val xs))"
proof -
  let ?xs = "list_of_oalist_tc xs"
  from assms have *: "OAlist_tc_min_key_val xs  set ?xs" by (rule OAlist_tc_min_key_val_in)
  show ?thesis unfolding OAlist_tc_lookup_def
    by (rule HOL.sym, rule tc.lookup_pair_eq_valueI, fact oalist_inv_list_of_oalist_tc, simp add: *)
qed

lemma OAlist_tc_min_key_val_minimal:
  assumes "z  set (list_of_oalist_tc xs)"
  shows "fst (OAlist_tc_min_key_val xs)  fst z"
proof -
  let ?xs = "list_of_oalist_tc xs"
  from assms have "?xs  []" by auto
  hence "OAlist_tc_sorted_domain xs  []" by (simp add: OAlist_tc_sorted_domain_def)
  then obtain h xs' where eq: "OAlist_tc_sorted_domain xs = h # xs'" using list.exhaust by blast
  with sorted_OAlist_tc_sorted_domain[of xs] have *: "yset xs'. h < y" by simp
  from assms have "fst z  set (OAlist_tc_sorted_domain xs)" by (simp add: OAlist_tc_sorted_domain_def)
  hence disj: "fst z = h  fst z  set xs'" by (simp add: eq)
  from ?xs  [] have "fst (OAlist_tc_min_key_val xs) = hd (OAlist_tc_sorted_domain xs)"
    by (simp add: OAlist_tc_min_key_val_def OAlist_tc_sorted_domain_def hd_map)
  also have "... = h" by (simp add: eq)
  also from disj have "...  fst z"
  proof
    assume "fst z = h"
    thus ?thesis by simp
  next
    assume "fst z  set xs'"
    with * have "h < fst z" ..
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

subsubsection @{const OAlist_tc_insert}

lemma list_of_oalist_OAlist_tc_insert [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_insert x xs) = update_by_pair_tc x (list_of_oalist_tc xs)"
  unfolding OAlist_tc_insert_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_pair, fact oalist_inv_list_of_oalist_tc)

lemma lookup_OAlist_tc_insert: "OAlist_tc_lookup (OAlist_tc_insert (k, v) xs) k' = (if k = k' then v else OAlist_tc_lookup xs k')"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)

subsubsection @{const OAlist_tc_update_by_fun} and @{const OAlist_tc_update_by_fun_gr}

lemma list_of_oalist_OAlist_tc_update_by_fun [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_update_by_fun k f xs) = update_by_fun_pair_tc k f (list_of_oalist_tc xs)"
  unfolding OAlist_tc_update_by_fun_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_pair, fact oalist_inv_list_of_oalist_tc)

lemma lookup_OAlist_tc_update_by_fun:
  "OAlist_tc_lookup (OAlist_tc_update_by_fun k f xs) k' = (if k = k' then f else id) (OAlist_tc_lookup xs k')"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_fun_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)

lemma list_of_oalist_OAlist_tc_update_by_fun_gr [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_update_by_fun_gr k f xs) = update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs)"
  unfolding OAlist_tc_update_by_fun_gr_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_gr_pair, fact oalist_inv_list_of_oalist_tc)

lemma OAlist_tc_update_by_fun_gr_eq_OAlist_tc_update_by_fun: "OAlist_tc_update_by_fun_gr = OAlist_tc_update_by_fun"
  by (rule, rule, rule,
      simp add: OAlist_tc_update_by_fun_gr_def OAlist_tc_update_by_fun_def
                tc.update_by_fun_gr_pair_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)

subsubsection @{const OAlist_tc_filter}

lemma list_of_oalist_OAlist_tc_filter [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_filter P xs) = filter P (list_of_oalist_tc xs)"
  unfolding OAlist_tc_filter_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_filter, fact oalist_inv_list_of_oalist_tc)

lemma lookup_OAlist_tc_filter: "OAlist_tc_lookup (OAlist_tc_filter P xs) k = (let v = OAlist_tc_lookup xs k in if P (k, v) then v else 0)"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_filter oalist_inv_list_of_oalist_tc)

subsubsection @{const OAlist_tc_map_val}

lemma list_of_oalist_OAlist_tc_map_val [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_map_val f xs) = map_val_pair f (list_of_oalist_tc xs)"
  unfolding OAlist_tc_map_val_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map_val_pair, fact oalist_inv_list_of_oalist_tc)

lemma OAlist_tc_map_val_cong:
  assumes "k v. (k, v)  set (list_of_oalist_tc xs)  f k v = g k v"
  shows "OAlist_tc_map_val f xs = OAlist_tc_map_val g xs"
  unfolding OAlist_tc_map_val_def by (rule arg_cong[where f=OAlist_tc], rule tc.map_val_pair_cong, elim assms)

lemma lookup_OAlist_tc_map_val: "f k 0 = 0  OAlist_tc_lookup (OAlist_tc_map_val f xs) k = f k (OAlist_tc_lookup xs k)"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map_val_pair oalist_inv_list_of_oalist_tc)

subsubsection @{const OAlist_tc_map2_val} @{const OAlist_tc_map2_val_rneutr} and @{const OAlist_tc_map2_val_neutr}

lemma list_of_oalist_map2_val [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_map2_val f xs ys) =
      map2_val_pair_tc f (map_val_pair (λk b. f k b 0)) (map_val_pair (λk. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
  unfolding OAlist_tc_map2_val_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
      fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
      fact tc.map2_val_compat_map_val_pair, fact tc.map2_val_compat_map_val_pair)

lemma list_of_oalist_OAlist_tc_map2_val_rneutr [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_map2_val_rneutr f xs ys) =
      map2_val_pair_tc f id (map_val_pair (λk c. f k 0 c)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
  unfolding OAlist_tc_map2_val_rneutr_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
      fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
      fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair)

lemma list_of_oalist_OAlist_tc_map2_val_neutr [simp, code abstract]:
  "list_of_oalist_tc (OAlist_tc_map2_val_neutr f xs ys) = map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
  unfolding OAlist_tc_map2_val_neutr_def
  by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
      fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
      fact tc.map2_val_compat_id, fact tc.map2_val_compat_id)

lemma lookup_OAlist_tc_map2_val:
  assumes "k. f k 0 0 = 0"
  shows "OAlist_tc_lookup (OAlist_tc_map2_val f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
  by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map2_val_pair
      tc.map2_val_compat_map_val_pair assms oalist_inv_list_of_oalist_tc)

lemma lookup_OAlist_tc_map2_val_rneutr:
  assumes "k x. f k x 0 = x"
  shows "OAlist_tc_lookup (OAlist_tc_map2_val_rneutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
  fix zs::"('a × 'b) list"
  assume "tc.oalist_inv_raw zs"
  thus "id zs = map_val_pair (λk v. f k v 0) zs" by (simp add: assms tc.map_pair_id)
qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
    fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair, rule refl, simp only: assms)

lemma lookup_OAlist_tc_map2_val_neutr:
  assumes "k x. f k x 0 = x" and "k x. f k 0 x = x"
  shows "OAlist_tc_lookup (OAlist_tc_map2_val_neutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
  fix zs::"('a × 'b) list"
  assume "tc.oalist_inv_raw zs"
  thus "id zs = map_val_pair (λk v. f k v 0) zs" by (simp add: assms(1) tc.map_pair_id)
next
  fix zs::"('a × 'b) list"
  assume "tc.oalist_inv_raw zs"
  thus "id zs = map_val_pair (λk. f k 0) zs" by (simp add: assms(2) tc.map_pair_id)
qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
    fact tc.map2_val_compat_id, fact tc.map2_val_compat_id, simp only: assms(1))

lemma OAlist_tc_map2_val_rneutr_singleton_eq_OAlist_tc_update_by_fun:
  assumes "a x. f a x 0 = x" and "list_of_oalist_tc ys = [(k, v)]"
  shows "OAlist_tc_map2_val_rneutr f xs ys = OAlist_tc_update_by_fun k (λx. f k x v) xs"
  by (simp add: OAlist_tc_map2_val_rneutr_def OAlist_tc_update_by_fun_def assms
      tc.map2_val_pair_singleton_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)

subsubsection @{const OAlist_tc_lex_ord} and @{const OAlist_tc_prod_ord}

lemma OAlist_tc_lex_ord_EqI:
  "(k. k  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
     f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq) 
  OAlist_tc_lex_ord f xs ys = Some Eq"
  by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqI,
      rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, blast)

lemma OAlist_tc_lex_ord_valI:
  assumes "aux  Some Eq" and "k  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)"
  shows "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) 
         (k'. k'  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
              k' < k  f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq) 
          OAlist_tc_lex_ord f xs ys = aux"
  by (simp (no_asm_use) add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_valI,
      rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, rule assms(1), rule assms(2), simp_all)

lemma OAlist_tc_lex_ord_EqD:
  "OAlist_tc_lex_ord f xs ys = Some Eq 
   k  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
   f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq"
  by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqD[where f=f],
      rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, assumption, simp)

lemma OAlist_tc_lex_ord_valE:
  assumes "OAlist_tc_lex_ord f xs ys = aux" and "aux  Some Eq"
  obtains k where "k  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)"
    and "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
    and "k'. k'  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
            k' < k  f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
proof -
  note oalist_inv_list_of_oalist_tc oalist_inv_list_of_oalist_tc
  moreover from assms(1) have "lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys) = aux"
    by (simp only: OAlist_tc_lex_ord_def)
  ultimately obtain k where 1: "k  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)"
    and "aux = f k (lookup_pair_tc (list_of_oalist_tc xs) k) (lookup_pair_tc (list_of_oalist_tc ys) k)"
    and "k'. k'  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
            k' < k 
            f k' (lookup_pair_tc (list_of_oalist_tc xs) k') (lookup_pair_tc (list_of_oalist_tc ys) k') = Some Eq"
    using assms(2) unfolding tc_le_lt[symmetric] by (rule tc.lex_ord_pair_valE, blast)
  from this(2, 3) have "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
    and "k'. k'  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys) 
            k' < k  f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
    by (simp_all only: OAlist_tc_lookup_def)
  with 1 show ?thesis ..
qed

lemma OAlist_tc_prod_ord_alt:
  "OAlist_tc_prod_ord P xs ys 
                  (kfst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys).
                      P k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k))"
  by (simp add: OAlist_tc_prod_ord_def OAlist_tc_lookup_def tc.prod_ord_pair_alt oalist_inv_list_of_oalist_tc)

subsubsection ‹Instance of @{class equal}

instantiation oalist_tc :: (linorder, zero) equal
begin

definition equal_oalist_tc :: "('a, 'b) oalist_tc  ('a, 'b) oalist_tc  bool"
  where "equal_oalist_tc xs ys = (list_of_oalist_tc xs = list_of_oalist_tc ys)"

instance by (intro_classes, simp add: equal_oalist_tc_def list_of_oalist_tc_inject)

end

subsection ‹Experiment›

lemma "oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)] = oalist_tc_of_list [(0, 4), (1, 3)]"
  by eval

lemma "OAlist_tc_except_min (oalist_tc_of_list ([(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)])) = oalist_tc_of_list [(1, 3)]"
  by eval

lemma "OAlist_tc_min_key_val (oalist_tc_of_list [(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)]) = (0, 4)"
  by eval

lemma "OAlist_tc_lookup (oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)]) 1 = 3"
  by eval

lemma "OAlist_tc_prod_ord (λ_. greater_eq)
                (oalist_tc_of_list [(1, 4), (0::nat, 4::nat), (1, 3), (0, 2), (3, 1)])
                (oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) = False"
  by eval

lemma "OAlist_tc_map2_val_rneutr (λ_. minus)
                (oalist_tc_of_list [(1, 4), (0::nat, 4::int), (1, 3), (0, 2), (3, 1)])
                (oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) =
             oalist_tc_of_list [(1, 1), (2, - 2), (3, 1)]"
  by eval

end (* theory *)

Theory OAlist_Poly_Mapping

(* Author: Alexander Maletzky *)

section ‹Ordered Associative Lists for Polynomials›

theory OAlist_Poly_Mapping
  imports PP_Type MPoly_Type_Class_Ordered OAlist
begin

text ‹We introduce a dedicated type for ordered associative lists (oalists) representing polynomials.
  To that end, we require the order relation the oalists are sorted wrt. to be admissible term orders,
  and furthermore sort the lists @{emph ‹descending›} rather than @{emph ‹ascending›}, because this
  allows to implement various operations more efficiently.
  For technical reasons, we must restrict the type of terms to types embeddable into
  @{typ "(nat, nat) pp × nat"}, though. All types we are interested in meet this requirement.›

lemma comparator_lexicographic:
  fixes f::"'a  'b" and g::"'a  'c"
  assumes "comparator c1" and "comparator c2" and "x y. f x = f y  g x = g y  x = y"
  shows "comparator (λx y. case c1 (f x) (f y) of Eq  c2 (g x) (g y) | val  val)"
          (is "comparator ?c3")
proof -
  from assms(1) interpret c1: comparator c1 .
  from assms(2) interpret c2: comparator c2 .
  show ?thesis
  proof
    fix x y :: 'a
    show "invert_order (?c3 x y) = ?c3 y x"
      by (simp add: c1.eq c2.eq split: order.split,
          metis invert_order.simps(1) invert_order.simps(2) c1.sym c2.sym order.distinct(5))
  next
    fix x y :: 'a
    assume "?c3 x y = Eq"
    hence "f x = f y" and "g x = g y" by (simp_all add: c1.eq c2.eq split: order.splits if_split_asm)
    thus "x = y" by (rule assms(3))
  next
    fix x y z :: 'a
    assume "?c3 x y = Lt"
    hence d1: "c1 (f x) (f y) = Lt  (c1 (f x) (f y) = Eq  c2 (g x) (g y) = Lt)"
      by (simp split: order.splits)
    assume "?c3 y z = Lt"
    hence d2: "c1 (f y) (f z) = Lt  (c1 (f y) (f z) = Eq  c2 (g y) (g z) = Lt)"
      by (simp split: order.splits)
    from d1 show "?c3 x z = Lt"
    proof
      assume 1: "c1 (f x) (f y) = Lt"
      from d2 show ?thesis
      proof
        assume "c1 (f y) (f z) = Lt"
        with 1 have "c1 (f x) (f z) = Lt" by (rule c1.comp_trans)
        thus ?thesis by simp
      next
        assume "c1 (f y) (f z) = Eq  c2 (g y) (g z) = Lt"
        hence "f z = f y" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
        with 1 show ?thesis by simp
      qed
    next
      assume "c1 (f x) (f y) = Eq  c2 (g x) (g y) = Lt"
      hence 1: "f x = f y" and 2: "c2 (g x) (g y) = Lt" by (simp_all add: c1.eq)
      from d2 show ?thesis
      proof
        assume "c1 (f y) (f z) = Lt"
        thus ?thesis by (simp add: 1)
      next
        assume "c1 (f y) (f z) = Eq  c2 (g y) (g z) = Lt"
        hence 3: "f y = f z" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
        from 2 this(2) have "c2 (g x) (g z) = Lt" by (rule c2.comp_trans)
        thus ?thesis by (simp add: 1 3)
      qed
    qed
  qed
qed

class nat_term =
  fixes rep_nat_term :: "'a  ((nat, nat) pp × nat)"
    and splus :: "'a  'a  'a"
  assumes rep_nat_term_inj: "rep_nat_term x = rep_nat_term y  x = y"
    and full_component: "snd (rep_nat_term x) = i  (y. rep_nat_term y = (t, i))"
    and splus_term: "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
begin

definition "lex_comp_aux = (λx y. case comp_of_ord lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y)) of
                                      Eq  comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) | val  val)"

lemma full_componentE:
  assumes "snd (rep_nat_term x) = i"
  obtains y where "rep_nat_term y = (t, i)"
proof -
  from assms have "y. rep_nat_term y = (t, i)" by (rule full_component)
  then obtain y where "rep_nat_term y = (t, i)" ..
  thus ?thesis ..
qed

end

class nat_pp_term = nat_term + zero + plus +
  assumes rep_nat_term_zero: "rep_nat_term 0 = (0, 0)"
    and splus_pp_term: "splus = (+)"

definition nat_term_comp :: "'a::nat_term comparator  bool"
  where "nat_term_comp cmp 
              (u v. snd (rep_nat_term u) = snd (rep_nat_term v)  fst (rep_nat_term u) = 0  cmp u v  Gt) 
              (u v. fst (rep_nat_term u) = fst (rep_nat_term v)  snd (rep_nat_term u) < snd (rep_nat_term v)  cmp u v = Lt) 
              (t u v. cmp u v = Lt  cmp (splus t u) (splus t v) = Lt) 
              (u v a b. fst (rep_nat_term u) = fst (rep_nat_term a)  fst (rep_nat_term v) = fst (rep_nat_term b) 
                  snd (rep_nat_term u) = snd (rep_nat_term v)  snd (rep_nat_term a) = snd (rep_nat_term b) 
                  cmp a b = Lt  cmp u v = Lt)"

lemma nat_term_compI:
  assumes "u v. snd (rep_nat_term u) = snd (rep_nat_term v)  fst (rep_nat_term u) = 0  cmp u v  Gt"
    and "u v. fst (rep_nat_term u) = fst (rep_nat_term v)  snd (rep_nat_term u) < snd (rep_nat_term v)  cmp u v = Lt"
    and "t u v. cmp u v = Lt  cmp (splus t u) (splus t v) = Lt"
    and "u v a b. fst (rep_nat_term u) = fst (rep_nat_term a)  fst (rep_nat_term v) = fst (rep_nat_term b) 
                  snd (rep_nat_term u) = snd (rep_nat_term v)  snd (rep_nat_term a) = snd (rep_nat_term b) 
                  cmp a b = Lt  cmp u v = Lt"
  shows "nat_term_comp cmp"
  unfolding nat_term_comp_def fst_conv snd_conv using assms by blast

lemma nat_term_compD1:
  assumes "nat_term_comp cmp" and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
  shows "cmp u v  Gt"
  using assms unfolding nat_term_comp_def fst_conv by blast

lemma nat_term_compD2:
  assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term v)" and "snd (rep_nat_term u) < snd (rep_nat_term v)"
  shows "cmp u v = Lt"
  using assms unfolding nat_term_comp_def fst_conv snd_conv by blast

lemma nat_term_compD3:
  assumes "nat_term_comp cmp" and "cmp u v = Lt"
  shows "cmp (splus t u) (splus t v) = Lt"
  using assms unfolding nat_term_comp_def snd_conv by blast

lemma nat_term_compD4:
  assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b = Lt"
  shows "cmp u v = Lt"
  using assms unfolding nat_term_comp_def snd_conv by blast

lemma nat_term_compD1':
  assumes "comparator cmp" and "nat_term_comp cmp" and "snd (rep_nat_term u)  snd (rep_nat_term v)"
    and "fst (rep_nat_term u) = 0"
  shows "cmp u v  Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
  case True
  with assms(2) show ?thesis using assms(4) by (rule nat_term_compD1)
next
  from assms(1) interpret cmp: comparator cmp .
  case False
  with assms(3) have a: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
  from refl obtain w::'a where eq: "rep_nat_term w = (0, snd (rep_nat_term v))" by (rule full_componentE)
  have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: eq assms(4) a)
  moreover have "cmp w v  Gt" by (rule nat_term_compD1, fact assms(2), simp_all add: eq)
  ultimately show "cmp u v  Gt" by (simp add: cmp.nGt_le_conv cmp.Lt_lt_conv)
qed

lemma nat_term_compD4':
  assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)"
  shows "cmp u v = cmp a b"
proof -
  from assms(1) interpret cmp: comparator cmp .
  show ?thesis
  proof (cases "cmp a b")
    case Eq
    hence "fst (rep_nat_term u) = fst (rep_nat_term v)" by (simp add: cmp.eq assms(3, 4))
    hence "rep_nat_term u = rep_nat_term v" using assms(5) by (rule prod_eqI)
    hence "u = v" by (rule rep_nat_term_inj)
    thus ?thesis by (simp add: Eq)
  next
    case Lt
    with assms(2, 3, 4, 5, 6) have "cmp u v = Lt" by (rule nat_term_compD4)
    thus ?thesis by (simp add: Lt)
  next
    case Gt
    hence "cmp b a = Lt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
    with assms(2, 4, 3) assms(5, 6)[symmetric] have "cmp v u = Lt" by (rule nat_term_compD4)
    hence "cmp u v = Gt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
    thus ?thesis by (simp add: Gt)
  qed
qed

lemma nat_term_compD4'':
  assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u)  snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b  Gt"
  shows "cmp u v  Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
  case True
  with assms(1, 2, 3, 4) have "cmp u v = cmp a b" using assms(6) by (rule nat_term_compD4')
  thus ?thesis using assms(7) by simp
next
  case False
  from assms(1) interpret cmp: comparator cmp .
  from refl obtain w::'a where w: "rep_nat_term w = (fst (rep_nat_term u), snd (rep_nat_term v))"
    by (rule full_componentE)
  have 1: "fst (rep_nat_term w) = fst (rep_nat_term a)" and 2: "snd (rep_nat_term w) = snd (rep_nat_term v)"
    by (simp_all add: w assms(3))
  from False assms(5) have *: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
  have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: * w)
  moreover from assms(1, 2) 1 assms(4) 2 assms(6) have "cmp w v = cmp a b" by (rule nat_term_compD4')
  ultimately show ?thesis using assms(7) by (metis cmp.nGt_le_conv cmp.nLt_le_conv cmp.comp_trans)
qed

lemma comparator_lex_comp_aux: "comparator (lex_comp_aux::'a::nat_term comparator)"
  unfolding lex_comp_aux_def
proof (rule comparator_composition)
  from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
  have "comparator (comp_of_ord (lex_pp::(nat, nat) pp  _))"
    unfolding comp_of_ord_eq_comp_of_ords[OF as]
    by (rule comp_of_ords, unfold_locales,
        auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
  thus "comparator (λx y::((nat, nat) pp × nat). case comp_of_ord lex_pp (fst x) (fst y) of
                                          Eq  comparator_of (snd x) (snd y) | val  val)"
    using comparator_of prod_eqI by (rule comparator_lexicographic)
next
  from rep_nat_term_inj show "inj rep_nat_term" by (rule injI)
qed

lemma nat_term_comp_lex_comp_aux: "nat_term_comp (lex_comp_aux::'a::nat_term comparator)"
proof -
  from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
  interpret lex: comparator "comp_of_ord (lex_pp::(nat, nat) pp  _)"
    unfolding comp_of_ord_eq_comp_of_ords[OF as]
    by (rule comp_of_ords, unfold_locales,
        auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
  show ?thesis
  proof (rule nat_term_compI)
    fix u v :: 'a
    assume 1: "snd (rep_nat_term u) = snd (rep_nat_term v)" and 2: "fst (rep_nat_term u) = 0"
    show "lex_comp_aux u v  Gt"
      by (simp add: lex_comp_aux_def 1 2 split: order.split, simp add: comp_of_ord_def lex_pp_zero_min)
  next
    fix u v :: 'a
    assume 1: "fst (rep_nat_term u) = fst (rep_nat_term v)" and 2: "snd (rep_nat_term u) < snd (rep_nat_term v)"
    show "lex_comp_aux u v = Lt"
      by (simp add: lex_comp_aux_def 1 split: order.split, simp add: comparator_of_def 2)
  next
    fix t u v :: 'a
    show "lex_comp_aux u v = Lt  lex_comp_aux (splus t u) (splus t v) = Lt"
      by (auto simp: lex_comp_aux_def splus_term pprod.splus_def comp_of_ord_def lex_pp_refl
          split: order.splits if_splits intro: lex_pp_plus_monotone')
  next
    fix u v a b :: 'a
    assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
      and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "lex_comp_aux a b = Lt"
    thus "lex_comp_aux u v = Lt" by (simp add: lex_comp_aux_def split: order.splits)
  qed
qed

typedef (overloaded) 'a nat_term_order =
  "{cmp::'a::nat_term comparator. comparator cmp  nat_term_comp cmp}"
  morphisms nat_term_compare Abs_nat_term_order
proof (rule, simp)
  from comparator_lex_comp_aux nat_term_comp_lex_comp_aux
  show "comparator lex_comp_aux  nat_term_comp lex_comp_aux" ..
qed

lemma nat_term_compare_Abs_nat_term_order_id:
  assumes "comparator cmp" and "nat_term_comp cmp"
  shows "nat_term_compare (Abs_nat_term_order cmp) = cmp"
  by (rule Abs_nat_term_order_inverse, simp add: assms)

instantiation nat_term_order :: (type) equal
begin

definition equal_nat_term_order :: "'a nat_term_order  'a nat_term_order  bool" where "equal_nat_term_order = (=)"

instance by (standard, simp add: equal_nat_term_order_def)

end

definition nat_term_compare_inv :: "'a nat_term_order  'a::nat_term comparator"
  where "nat_term_compare_inv to = (λx y. nat_term_compare to y x)"

definition key_order_of_nat_term_order :: "'a nat_term_order  'a::nat_term key_order"
  where key_order_of_nat_term_order_def [code del]:
    "key_order_of_nat_term_order to = Abs_key_order (nat_term_compare to)"

definition key_order_of_nat_term_order_inv :: "'a nat_term_order  'a::nat_term key_order"
  where key_order_of_nat_term_order_inv_def [code del]:
    "key_order_of_nat_term_order_inv to = Abs_key_order (nat_term_compare_inv to)"

definition le_of_nat_term_order :: "'a nat_term_order  'a  'a::nat_term  bool"
  where "le_of_nat_term_order to = le_of_key_order (key_order_of_nat_term_order to)"

definition lt_of_nat_term_order :: "'a nat_term_order  'a  'a::nat_term  bool"
  where "lt_of_nat_term_order to = lt_of_key_order (key_order_of_nat_term_order to)"

definition nat_term_order_of_le :: "'a::{linorder,nat_term} nat_term_order"
  where "nat_term_order_of_le = Abs_nat_term_order (comparator_of)"

lemma comparator_nat_term_compare: "comparator (nat_term_compare to)"
  using nat_term_compare by blast

lemma nat_term_comp_nat_term_compare: "nat_term_comp (nat_term_compare to)"
  using nat_term_compare by blast

lemma nat_term_compare_splus: "nat_term_compare to (splus t u) (splus t v) = nat_term_compare to u v"
proof -
  from comparator_nat_term_compare interpret cmp: comparator "nat_term_compare to" .
  show ?thesis
  proof (cases "nat_term_compare to u v")
    case Eq
    hence "splus t u = splus t v" by (simp add: cmp.eq)
    thus ?thesis by (simp add: cmp.eq Eq)
  next
    case Lt
    moreover from nat_term_comp_nat_term_compare this have "nat_term_compare to (splus t u) (splus t v) = Lt"
      by (rule nat_term_compD3)
    ultimately show ?thesis by simp
  next
    case Gt
    hence "nat_term_compare to v u = Lt" using cmp.Gt_lt_conv cmp.Lt_lt_conv by auto
    with nat_term_comp_nat_term_compare have "nat_term_compare to (splus t v) (splus t u) = Lt"
      by (rule nat_term_compD3)
    hence "nat_term_compare to (splus t u) (splus t v) = Gt" using cmp.Gt_lt_conv cmp.Lt_lt_conv by auto
    with Gt show ?thesis by simp
  qed
qed

lemma nat_term_compare_conv: "nat_term_compare to = key_compare (key_order_of_nat_term_order to)"
  unfolding key_order_of_nat_term_order_def
  by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare)

lemma comparator_nat_term_compare_inv: "comparator (nat_term_compare_inv to)"
  unfolding nat_term_compare_inv_def using comparator_nat_term_compare by (rule comparator_converse)

lemma nat_term_compare_inv_conv: "nat_term_compare_inv to = key_compare (key_order_of_nat_term_order_inv to)"
  unfolding key_order_of_nat_term_order_inv_def
  by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare_inv)

lemma nat_term_compare_inv_alt [code_unfold]: "nat_term_compare_inv to x y = nat_term_compare to y x"
  by (simp only: nat_term_compare_inv_def)

lemma le_of_nat_term_order [code]: "le_of_nat_term_order to x y = (nat_term_compare to x y  Gt)"
  by (simp add: le_of_key_order_alt le_of_nat_term_order_def nat_term_compare_conv)

lemma lt_of_nat_term_order [code]: "lt_of_nat_term_order to x y = (nat_term_compare to x y = Lt)"
  by (simp add: lt_of_key_order_alt lt_of_nat_term_order_def nat_term_compare_conv)

lemma le_of_nat_term_order_alt:
  "le_of_nat_term_order to = (λu v. ko.le (key_order_of_nat_term_order_inv to) v u)"
  by (intro ext, simp add: le_of_comp_def nat_term_compare_inv_conv[symmetric] le_of_nat_term_order_def
      le_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)

lemma lt_of_nat_term_order_alt:
  "lt_of_nat_term_order to = (λu v. ko.lt (key_order_of_nat_term_order_inv to) v u)"
  by (intro ext, simp add: lt_of_comp_def nat_term_compare_inv_conv[symmetric] lt_of_nat_term_order_def
      lt_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)

lemma linorder_le_of_nat_term_order: "class.linorder (le_of_nat_term_order to) (lt_of_nat_term_order to)"
  unfolding le_of_nat_term_order_alt lt_of_nat_term_order_alt using ko.linorder
  by (rule linorder.dual_linorder)

lemma le_of_nat_term_order_zero_min: "le_of_nat_term_order to 0 (t::'a::nat_pp_term)"
  unfolding le_of_nat_term_order
  by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare, simp_all add: rep_nat_term_zero)

lemma le_of_nat_term_order_plus_monotone:
  assumes "le_of_nat_term_order to s (t::'a::nat_pp_term)"
  shows "le_of_nat_term_order to (u + s) (u + t)"
  using assms by (simp add: le_of_nat_term_order splus_pp_term[symmetric] nat_term_compare_splus)

global_interpretation ko_ntm: comparator "nat_term_compare_inv ko"
  defines lookup_pair_ko_ntm = ko_ntm.lookup_pair
  and update_by_pair_ko_ntm = ko_ntm.update_by_pair
  and update_by_fun_pair_ko_ntm = ko_ntm.update_by_fun_pair
  and update_by_fun_gr_pair_ko_ntm = ko_ntm.update_by_fun_gr_pair
  and map2_val_pair_ko_ntm = ko_ntm.map2_val_pair
  and lex_ord_pair_ko_ntm = ko_ntm.lex_ord_pair
  and prod_ord_pair_ko_ntm = ko_ntm.prod_ord_pair
  and sort_oalist_ko_ntm' = ko_ntm.sort_oalist
  by (fact comparator_nat_term_compare_inv)

lemma ko_ntm_le: "ko_ntm.le to = (λx y. le_of_nat_term_order to y x)"
  by (intro ext, simp add: le_of_comp_def le_of_nat_term_order nat_term_compare_inv_def split: order.split)

global_interpretation ko_ntm: oalist_raw key_order_of_nat_term_order_inv
  rewrites "comparator.lookup_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lookup_pair_ko_ntm ko"
  and "comparator.update_by_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_pair_ko_ntm ko"
  and "comparator.update_by_fun_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_pair_ko_ntm ko"
  and "comparator.update_by_fun_gr_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_gr_pair_ko_ntm ko"
  and "comparator.map2_val_pair (key_compare (key_order_of_nat_term_order_inv ko)) = map2_val_pair_ko_ntm ko"
  and "comparator.lex_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lex_ord_pair_ko_ntm ko"
  and "comparator.prod_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = prod_ord_pair_ko_ntm ko"
  and "comparator.sort_oalist (key_compare (key_order_of_nat_term_order_inv ko)) = sort_oalist_ko_ntm' ko"
  defines sort_oalist_aux_ko_ntm = ko_ntm.sort_oalist_aux
  and lookup_ko_ntm = ko_ntm.lookup_raw
  and sorted_domain_ko_ntm = ko_ntm.sorted_domain_raw
  and tl_ko_ntm = ko_ntm.tl_raw
  and min_key_val_ko_ntm = ko_ntm.min_key_val_raw
  and update_by_ko_ntm = ko_ntm.update_by_raw
  and update_by_fun_ko_ntm = ko_ntm.update_by_fun_raw
  and update_by_fun_gr_ko_ntm = ko_ntm.update_by_fun_gr_raw
  and map2_val_ko_ntm = ko_ntm.map2_val_raw
  and lex_ord_ko_ntm = ko_ntm.lex_ord_raw
  and prod_ord_ko_ntm = ko_ntm.prod_ord_raw
  and oalist_eq_ko_ntm = ko_ntm.oalist_eq_raw
  and sort_oalist_ko_ntm = ko_ntm.sort_oalist_raw
  subgoal by (simp only: lookup_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_fun_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_fun_gr_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: map2_val_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: lex_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: prod_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: sort_oalist_ko_ntm'_def nat_term_compare_inv_conv)
  done

lemma compute_min_key_val_ko_ntm [code]:
  "min_key_val_ko_ntm ko (xs, ox) =
      (if ko = ox then hd else min_list_param (λx y. (le_of_nat_term_order ko) (fst y) (fst x))) xs"
proof -
  have "ko.le (key_order_of_nat_term_order_inv ko) = (λx y. le_of_nat_term_order ko y x)"
    by (metis ko.nGt_le_conv le_of_nat_term_order nat_term_compare_inv_conv nat_term_compare_inv_def)
  thus ?thesis by (simp only: min_key_val_ko_ntm_def oalist_raw.min_key_val_raw.simps)
qed

typedef (overloaded) ('a, 'b) oalist_ntm =
    "{xs::('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw. ko_ntm.oalist_inv xs}"
  morphisms list_of_oalist_ntm Abs_oalist_ntm
  by (auto simp: ko_ntm.oalist_inv_def intro: ko.oalist_inv_raw_Nil)

lemma oalist_ntm_eq_iff: "xs = ys  list_of_oalist_ntm xs = list_of_oalist_ntm ys"
  by (simp add: list_of_oalist_ntm_inject)

lemma oalist_ntm_eqI: "list_of_oalist_ntm xs = list_of_oalist_ntm ys  xs = ys"
  by (simp add: oalist_ntm_eq_iff)

text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist_ntm"}:›

definition OAlist_ntm :: "('a × 'b) list × 'a nat_term_order  ('a::nat_term, 'b::zero) oalist_ntm"
  where "OAlist_ntm xs = Abs_oalist_ntm (sort_oalist_ko_ntm xs)"

definition "oalist_of_list_ntm = OAlist_ntm"

lemma oalist_inv_list_of_oalist_ntm: "ko_ntm.oalist_inv (list_of_oalist_ntm xs)"
  using list_of_oalist_ntm[of xs] by simp

lemma list_of_oalist_OAlist_ntm: "list_of_oalist_ntm (OAlist_ntm xs) = sort_oalist_ko_ntm xs"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  have "ko_ntm.oalist_inv (sort_oalist_ko_ntm' ox xs', ox)"
    using ko_ntm.oalist_inv_sort_oalist_raw by fastforce
  thus ?thesis by (simp add: xs OAlist_ntm_def Abs_oalist_ntm_inverse)
qed

lemma OAlist_list_of_oalist_ntm [simp, code abstype]: "OAlist_ntm (list_of_oalist_ntm xs) = xs"
proof -
  obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
  have "ko_ntm.oalist_inv_raw ox xs'"
    by (simp add: xs[symmetric] ko_ntm.oalist_inv_alt[symmetric] nat_term_compare_inv_conv oalist_inv_list_of_oalist_ntm)
  thus ?thesis by (simp add: xs OAlist_ntm_def ko_ntm.sort_oalist_id, simp add: list_of_oalist_ntm_inverse xs[symmetric])
qed

lemma [code abstract]: "list_of_oalist_ntm (oalist_of_list_ntm xs) = sort_oalist_ko_ntm xs"
  by (simp add: list_of_oalist_OAlist_ntm oalist_of_list_ntm_def)

global_interpretation oa_ntm: oalist_abstract key_order_of_nat_term_order_inv list_of_oalist_ntm OAlist_ntm
  defines OAlist_lookup_ntm = oa_ntm.lookup
  and OAlist_sorted_domain_ntm = oa_ntm.sorted_domain
  and OAlist_empty_ntm = oa_ntm.empty
  and OAlist_reorder_ntm = oa_ntm.reorder
  and OAlist_tl_ntm = oa_ntm.tl
  and OAlist_hd_ntm = oa_ntm.hd
  and OAlist_except_min_ntm = oa_ntm.except_min
  and OAlist_min_key_val_ntm = oa_ntm.min_key_val
  and OAlist_insert_ntm = oa_ntm.insert
  and OAlist_update_by_fun_ntm = oa_ntm.update_by_fun
  and OAlist_update_by_fun_gr_ntm = oa_ntm.update_by_fun_gr
  and OAlist_filter_ntm = oa_ntm.filter
  and OAlist_map2_val_neutr_ntm = oa_ntm.map2_val_neutr
  and OAlist_eq_ntm = oa_ntm.oalist_eq
  apply unfold_locales
  subgoal by (fact oalist_inv_list_of_oalist_ntm)
  subgoal by (simp only: list_of_oalist_OAlist_ntm sort_oalist_ko_ntm_def)
  subgoal by (fact OAlist_list_of_oalist_ntm)
  done

global_interpretation oa_ntm: oalist_abstract3 key_order_of_nat_term_order_inv
    "list_of_oalist_ntm::('a, 'b) oalist_ntm  ('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw" OAlist_ntm
    "list_of_oalist_ntm::('a, 'c) oalist_ntm  ('a, 'c::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
    "list_of_oalist_ntm::('a, 'd) oalist_ntm  ('a, 'd::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
  defines OAlist_map_val_ntm = oa_ntm.map_val
  and OAlist_map2_val_ntm = oa_ntm.map2_val
  and OAlist_map2_val_rneutr_ntm = oa_ntm.map2_val_rneutr
  and OAlist_lex_ord_ntm = oa_ntm.lex_ord
  and OAlist_prod_ord_ntm = oa_ntm.prod_ord ..

lemmas OAlist_lookup_ntm_single = oa_ntm.lookup_oalist_of_list_single[folded oalist_of_list_ntm_def]

end (* theory *)

Theory Term_Order

(* Author: Alexander Maletzky *)

section ‹Computable Term Orders›

theory Term_Order
  imports OAlist_Poly_Mapping "HOL-Library.Product_Lexorder"
begin

subsection ‹Type Class nat›

class nat = zero + plus + minus + order + equal +
  fixes rep_nat :: "'a  nat"
    and abs_nat :: "nat  'a"
  assumes rep_inverse [simp]: "abs_nat (rep_nat x) = x"
    and abs_inverse [simp]: "rep_nat (abs_nat n) = n"
    and abs_zero [simp]: "abs_nat 0 = 0"
    and abs_plus: "abs_nat m + abs_nat n = abs_nat (m + n)"
    and abs_minus: "abs_nat m - abs_nat n = abs_nat (m - n)"
    and abs_ord: "m  n  abs_nat m  abs_nat n"
begin

lemma rep_inj:
  assumes "rep_nat x = rep_nat y"
  shows "x = y"
proof -
  have "abs_nat (rep_nat x) = abs_nat (rep_nat y)" by (simp only: assms)
  thus ?thesis by (simp only: rep_inverse)
qed

corollary rep_eq_iff: "(rep_nat x = rep_nat y)  (x = y)"
  by (auto elim: rep_inj)

lemma abs_inj:
  assumes "abs_nat m = abs_nat n"
  shows "m = n"
proof -
  have "rep_nat (abs_nat m) = rep_nat (abs_nat n)" by (simp only: assms)
  thus ?thesis by (simp only: abs_inverse)
qed

corollary abs_eq_iff: "(abs_nat m = abs_nat n)  (m = n)"
  by (auto elim: abs_inj)

lemma rep_zero [simp]: "rep_nat 0 = 0"
  using abs_inverse abs_zero by fastforce

lemma rep_zero_iff: "(rep_nat x = 0)  (x = 0)"
  using rep_eq_iff by fastforce

lemma plus_eq: "x + y = abs_nat (rep_nat x + rep_nat y)"
  by (metis abs_plus rep_inverse)

lemma rep_plus: "rep_nat (x + y) = rep_nat x + rep_nat y"
  by (simp add: plus_eq)

lemma minus_eq: "x - y = abs_nat (rep_nat x - rep_nat y)"
  by (metis abs_minus rep_inverse)

lemma rep_minus: "rep_nat (x - y) = rep_nat x - rep_nat y"
  by (simp add: minus_eq)

lemma ord_iff:
  "x  y  rep_nat x  rep_nat y" (is ?thesis1)
  "x < y  rep_nat x < rep_nat y" (is ?thesis2)
proof -
  show ?thesis1
  proof
    assume "x  y"
    show "rep_nat x  rep_nat y"
    proof (rule ccontr)
      assume "¬ rep_nat x  rep_nat y"
      hence "rep_nat y  rep_nat x" and "rep_nat x  rep_nat y" by simp_all
      from this(1) have "abs_nat (rep_nat y)  abs_nat (rep_nat x)" by (rule abs_ord)
      hence "y  x" by (simp only: rep_inverse)
      moreover from ‹rep_nat x  rep_nat y have "y  x" using rep_inj by auto
      ultimately have "y < x" by simp
      with x  y show False by simp
    qed
  next
    assume "rep_nat x  rep_nat y"
    hence "abs_nat (rep_nat x)  abs_nat (rep_nat y)" by (rule abs_ord)
    thus "x  y" by (simp only: rep_inverse)
  qed
  thus ?thesis2 using rep_inj[of x y] by (auto simp: less_le Nat.nat_less_le)
qed

lemma ex_iff_abs: "(x::'a. P x)  (n::nat. P (abs_nat n))"
  by (metis rep_inverse)

lemma ex_iff_abs': "(x<abs_nat m. P x)  (n::nat<m. P (abs_nat n))"
  by (metis abs_inverse rep_inverse ord_iff(2))

lemma all_iff_abs: "(x::'a. P x)  (n::nat. P (abs_nat n))"
  by (metis rep_inverse)

lemma all_iff_abs': "(x<abs_nat m. P x)  (n::nat<m. P (abs_nat n))"
  by (metis abs_inverse rep_inverse ord_iff(2))

subclass linorder by (standard, auto simp: ord_iff rep_inj)

lemma comparator_of_rep [simp]: "comparator_of (rep_nat x) (rep_nat y) = comparator_of x y"
  by (simp add: comparator_of_def linorder_class.comparator_of_def ord_iff rep_inj)

subclass wellorder
proof
  fix P::"'a  bool" and a::'a
  let ?P = "λn::nat. P (abs_nat n)"
  assume a: "x. (y. y < x  P y)  P x"
  have "P (abs_nat (rep_nat a))"
  proof (rule less_induct[of _ "rep_nat a"])
    fix n::nat
    assume b: "m. m < n  ?P m"
    show "?P n"
    proof (rule a)
      fix y
      assume "y < abs_nat n"
      hence "rep_nat y < n" by (simp only: ord_iff abs_inverse)
      hence "?P (rep_nat y)" by (rule b)
      thus "P y" by (simp only: rep_inverse)
    qed
  qed
  thus "P a" by (simp only: rep_inverse)
qed

subclass comm_monoid_add by (standard, auto simp: plus_eq intro: arg_cong)

lemma sum_rep: "sum (rep_nat  f) A = rep_nat (sum f A)" for f :: "'b  'a" and A :: "'b set"
proof (induct A rule: infinite_finite_induct)
  case (infinite A)
  thus ?case by simp
next
  case empty
  show ?case by simp
next
  case (insert a A)
  from insert(1, 2) show ?case by (simp del: comp_apply add: insert(3) rep_plus, simp)
qed

subclass ordered_comm_monoid_add by (standard, simp add: ord_iff plus_eq)

subclass countable by intro_classes (intro exI[of _ rep_nat] injI, elim rep_inj)

subclass cancel_comm_monoid_add
  apply standard
  subgoal by (simp add: minus_eq rep_plus)
  subgoal by (simp add: minus_eq rep_plus)
  done

subclass add_wellorder
  apply standard
  subgoal by (simp add: ord_iff rep_plus)
  subgoal unfolding ord_iff by (drule le_imp_add, metis abs_plus rep_inverse)
  subgoal by (simp add: ord_iff)
  done

end

lemma the_min_eq_zero: "the_min = (0::'a::{the_min,nat})"
proof -
  have "the_min  (0::'a)" by (fact the_min_min)
  hence "rep_nat (the_min::'a)  rep_nat (0::'a)" by (simp only: ord_iff)
  also have "... = 0" by simp
  finally have "rep_nat (the_min::'a) = 0" by simp
  thus ?thesis by (simp only: rep_zero_iff)
qed

instantiation nat :: nat
begin

definition rep_nat_nat :: "nat  nat" where rep_nat_nat_def [code_unfold]: "rep_nat_nat = (λx. x)"
definition abs_nat_nat :: "nat  nat" where abs_nat_nat_def [code_unfold]: "abs_nat_nat = (λx. x)"

instance by (standard, simp_all add: rep_nat_nat_def abs_nat_nat_def)

end

instantiation natural :: nat
begin

definition rep_nat_natural :: "natural  nat"
  where rep_nat_natural_def [code_unfold]: "rep_nat_natural = nat_of_natural"
definition abs_nat_natural :: "nat  natural"
  where abs_nat_natural_def [code_unfold]: "abs_nat_natural = natural_of_nat"

instance by (standard, simp_all add: rep_nat_natural_def abs_nat_natural_def, metis minus_natural.rep_eq nat_of_natural_of_nat of_nat_of_natural)

end

subsection ‹Term Orders›

subsubsection ‹Type Classes›

class nat_pp_compare = linorder + zero + plus +
  fixes rep_nat_pp :: "'a  (nat, nat) pp"
    and abs_nat_pp :: "(nat, nat) pp  'a"
    and lex_comp' :: "'a comparator"
    and deg' :: "'a  nat"
  assumes rep_nat_pp_inverse [simp]: "abs_nat_pp (rep_nat_pp x) = x"
    and abs_nat_pp_inverse [simp]: "rep_nat_pp (abs_nat_pp t) = t"
    and lex_comp': "lex_comp' x y = comp_of_ord lex_pp (rep_nat_pp x) (rep_nat_pp y)"
    and deg': "deg' x = deg_pp (rep_nat_pp x)"
    and le_pp: "rep_nat_pp x  rep_nat_pp y  x  y"
    and zero_pp: "rep_nat_pp 0 = 0"
    and plus_pp: "rep_nat_pp (x + y) = rep_nat_pp x + rep_nat_pp y"
begin

lemma less_pp:
  assumes "rep_nat_pp x < rep_nat_pp y"
  shows "x < y"
proof -
  from assms have 1: "rep_nat_pp x  rep_nat_pp y" and 2: "rep_nat_pp x  rep_nat_pp y" by simp_all
  from 1 have "x  y" by (rule le_pp)
  moreover from 2 have "x  y" by auto
  ultimately show ?thesis by simp
qed

lemma rep_nat_pp_inj:
  assumes "rep_nat_pp x = rep_nat_pp y"
  shows "x = y"
proof -
  have "abs_nat_pp (rep_nat_pp x) = abs_nat_pp (rep_nat_pp y)" by (simp only: assms)
  thus ?thesis by simp
qed

lemma lex_comp'_EqD:
  assumes "lex_comp' x y = Eq"
  shows "x = y"
proof (rule rep_nat_pp_inj)
  from assms show "rep_nat_pp x = rep_nat_pp y" by (simp add: lex_comp' comp_of_ord_def split: if_split_asm)
qed

lemma lex_comp'_valE:
  assumes "lex_comp' s t  Eq"
  obtains x where "x  keys_pp (rep_nat_pp s)  keys_pp (rep_nat_pp t)"
    and "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
    and "y. y < x  lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y"
proof (cases "lex_comp' s t")
  case Eq
  with assms show ?thesis ..
next
  case Lt
  hence "rep_nat_pp s  rep_nat_pp t" and "lex_pp (rep_nat_pp s) (rep_nat_pp t)"
    by (auto simp: lex_comp' comp_of_ord_def split: if_split_asm)
  hence "x. lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x 
             (y<x. lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y)"
    by (simp add: lex_pp_alt)
  then obtain x where 1: "lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x"
    and 2: "y. y < x  lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y" by blast
  show ?thesis
  proof
    show "x  keys_pp (rep_nat_pp s)  keys_pp (rep_nat_pp t)"
    proof (rule ccontr)
      assume "x  keys_pp (rep_nat_pp s)  keys_pp (rep_nat_pp t)"
      with 1 show False by (simp add: keys_pp_iff)
    qed
  next
    show "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
      by (simp add: linorder_class.comparator_of_def 1 Lt)
  qed (fact 2)
next
  case Gt
  hence "¬ lex_pp (rep_nat_pp s) (rep_nat_pp t)"
    by (auto simp: lex_comp' comp_of_ord_def split: if_split_asm)
  hence "lex_pp (rep_nat_pp t) (rep_nat_pp s)" by (rule lex_pp_lin')
  moreover have "rep_nat_pp t  rep_nat_pp s"
  proof
    assume "rep_nat_pp t = rep_nat_pp s"
    moreover from this have "lex_pp (rep_nat_pp s) (rep_nat_pp t)" by (simp add: lex_pp_refl)
    ultimately have "lex_comp' s t = Eq" by (simp add: lex_comp' comp_of_ord_def)
    with Gt show False by simp
  qed
  ultimately have "x. lookup_pp (rep_nat_pp t) x < lookup_pp (rep_nat_pp s) x 
                    (y<x. lookup_pp (rep_nat_pp t) y = lookup_pp (rep_nat_pp s) y)"
    by (simp add: lex_pp_alt)
  then obtain x where 1: "lookup_pp (rep_nat_pp t) x < lookup_pp (rep_nat_pp s) x"
    and 2: "y. y < x  lookup_pp (rep_nat_pp t) y = lookup_pp (rep_nat_pp s) y" by blast
  show ?thesis
  proof
    show "x  keys_pp (rep_nat_pp s)  keys_pp (rep_nat_pp t)"
    proof (rule ccontr)
      assume "x  keys_pp (rep_nat_pp s)  keys_pp (rep_nat_pp t)"
      with 1 show False by (simp add: keys_pp_iff)
    qed
  next
    from 1 have "¬ lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x"
      and "lookup_pp (rep_nat_pp s) x  lookup_pp (rep_nat_pp t) x" by simp_all
    thus "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
      by (simp add: linorder_class.comparator_of_def Gt)
  qed (simp add: 2)
qed

end

class nat_term_compare = linorder + nat_term +
  fixes is_scalar :: "'a itself  bool"
    and lex_comp :: "'a comparator"
    and deg_comp :: "'a comparator  'a comparator"
    and pot_comp :: "'a comparator  'a comparator"
  assumes zero_component: "x. snd (rep_nat_term x) = 0"
    and is_scalar: "is_scalar = (λ_. x. snd (rep_nat_term x) = 0)"
    and lex_comp: "lex_comp = lex_comp_aux" ―‹For being able to implement lex_comp› efficiently.›
    and deg_comp: "deg_comp cmp = (λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq  cmp x y | val  val)"
    and pot_comp: "pot_comp cmp = (λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq  cmp x y | val  val)"
    and le_term: "rep_nat_term x  rep_nat_term y  x  y"
begin

text ‹There is no need to add something like top_comp› for TOP orders to class @{class nat_term_compare},
  because by default all comparators should @{emph ‹first›} compare power-products and @{emph ‹then›} positions.
  lex_comp› obviously does.›

lemma less_term:
  assumes "rep_nat_term x < rep_nat_term y"
  shows "x < y"
proof -
  from assms have 1: "rep_nat_term x  rep_nat_term y" and 2: "rep_nat_term x  rep_nat_term y" by simp_all
  from 1 have "x  y" by (rule le_term)
  moreover from 2 have "x  y" by auto
  ultimately show ?thesis by simp
qed

lemma lex_comp_alt: "lex_comp = (comparator_of::'a comparator)"
proof -
  from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
  interpret lex: comparator "comp_of_ord (lex_pp::(nat, nat) pp  _)"
    unfolding comp_of_ord_eq_comp_of_ords[OF as]
    by (rule comp_of_ords, unfold_locales,
        auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)

  have 1: "x = y" if "fst (rep_nat_term x) = fst (rep_nat_term y)"
                  and "snd (rep_nat_term x) = snd (rep_nat_term y)" for x y
    by (rule rep_nat_term_inj, rule prod_eqI, fact+)
  have 2: "x < y" if "fst (rep_nat_term x) = fst (rep_nat_term y)"
                  and "snd (rep_nat_term x) < snd (rep_nat_term y)" for x y
    by (rule less_term, simp add: less_prod_def that)
  have 3: False if "fst (rep_nat_term x) = fst (rep_nat_term y)"
                and "¬ snd (rep_nat_term x) < snd (rep_nat_term y)" and "x < y" for x y
  proof -
    from that(2) have a: "snd (rep_nat_term y)  snd (rep_nat_term x)" by simp
    have "y  x" by (rule le_term, simp add: less_eq_prod_def that(1) a)
    also have "... < y" by fact
    finally show False ..
  qed
  have 4: "x < y" if "fst (rep_nat_term x)  fst (rep_nat_term y)"
                  and "lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y))" for x y
  proof -
    from that(2) have "fst (rep_nat_term x)  fst (rep_nat_term y)" by (simp only: less_eq_pp_def)
    with that(1) have "fst (rep_nat_term x) < fst (rep_nat_term y)" by simp
    hence "rep_nat_term x < rep_nat_term y" by (simp add: less_prod_def)
    thus ?thesis by (rule less_term)
  qed
  have 5: False if "fst (rep_nat_term x)  fst (rep_nat_term y)"
                and "¬ lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y))" and "x < y" for x y
  proof -
    from that(2) have a: "lex_pp (fst (rep_nat_term y)) (fst (rep_nat_term x))" by (rule lex_pp_lin')
    with that(1)[symmetric] have "y < x" by (rule 4)
    also have "... < y" by fact
    finally show False ..
  qed

  show ?thesis
    by (intro ext, simp add: lex_comp lex_comp_aux_def comparator_of_def linorder_class.comparator_of_def lex.eq split: order.splits,
        auto simp: lex_pp_refl comp_of_ord_def elim: 1 2 3 4 5)
qed

lemma full_component_zeroE: obtains x where "rep_nat_term x = (t, 0)"
proof -
  from zero_component obtain x' where "snd (rep_nat_term x') = 0" ..
  then obtain x where "rep_nat_term x = (t, 0)" by (rule full_componentE)
  thus ?thesis ..
qed

end

(* For some reason, the following lemmas cannot be stated in context "nat_term_compare". *)

lemma comparator_lex_comp: "comparator lex_comp"
  unfolding lex_comp by (fact comparator_lex_comp_aux)

lemma nat_term_comp_lex_comp: "nat_term_comp lex_comp"
  unfolding lex_comp by (fact nat_term_comp_lex_comp_aux)

lemma comparator_deg_comp:
  assumes "comparator cmp"
  shows "comparator (deg_comp cmp)"
  unfolding deg_comp using comparator_of assms by (rule comparator_lexicographic)

lemma comparator_pot_comp:
  assumes "comparator cmp"
  shows "comparator (pot_comp cmp)"
  unfolding pot_comp using comparator_of assms by (rule comparator_lexicographic)

lemma deg_comp_zero_min:
  assumes "comparator cmp" and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
  shows "deg_comp cmp u v  Gt"
proof (simp add: deg_comp assms(3) comparator_of_def split: order.split, intro impI)
  assume "fst (rep_nat_term v) = 0"
  with assms(3) have "fst (rep_nat_term u) = fst (rep_nat_term v)" by simp
  hence "rep_nat_term u = rep_nat_term v" using assms(2) by (rule prod_eqI)
  hence "u = v" by (rule rep_nat_term_inj)
  from assms(1) interpret c: comparator cmp .
  show "cmp u v  Gt" by (simp add: u = v)
qed

lemma deg_comp_pos:
  assumes "cmp u v = Lt" and "fst (rep_nat_term u) = fst (rep_nat_term v)"
  shows "deg_comp cmp u v = Lt"
  by (simp add: deg_comp assms split: order.split)

lemma deg_comp_monotone:
  assumes "cmp u v = Lt  cmp (splus t u) (splus t v) = Lt" and "deg_comp cmp u v = Lt"
  shows "deg_comp cmp (splus t u) (splus t v) = Lt"
  using assms(2) by (auto simp: deg_comp splus_term pprod.splus_def comparator_of_def deg_pp_plus
                          split: order.splits if_splits intro: assms(1))

lemma pot_comp_zero_min:
  assumes "cmp u v  Gt" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
  shows "pot_comp cmp u v  Gt"
  by (simp add: pot_comp comparator_of_def assms split: order.split)

lemma pot_comp_pos:
  assumes "snd (rep_nat_term u) < snd (rep_nat_term v)"
  shows "pot_comp cmp u v = Lt"
  by (simp add: pot_comp comparator_of_def assms split: order.split)

lemma pot_comp_monotone:
  assumes "cmp u v = Lt  cmp (splus t u) (splus t v) = Lt" and "pot_comp cmp u v = Lt"
  shows "pot_comp cmp (splus t u) (splus t v) = Lt"
  using assms(2) by (auto simp: pot_comp splus_term pprod.splus_def comparator_of_def deg_pp_plus
                          split: order.splits if_splits intro: assms(1))

lemma deg_comp_cong:
  assumes "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))  to1 u v = to2 u v"
  shows "deg_comp to1 u v = deg_comp to2 u v"
  using assms by (simp add: deg_comp comparator_of_def split: order.split)

lemma pot_comp_cong:
  assumes "snd (rep_nat_term u) = snd (rep_nat_term v)  to1 u v = to2 u v"
  shows "pot_comp to1 u v = pot_comp to2 u v"
  using assms by (simp add: pot_comp comparator_of_def split: order.split)

instantiation pp :: (nat, nat) nat_pp_compare
begin

definition rep_nat_pp_pp :: "('a, 'b) pp  (nat, nat) pp"
  where rep_nat_pp_pp_def [code del]: "rep_nat_pp_pp x = pp_of_fun (λn::nat. rep_nat (lookup_pp x (abs_nat n)))"

definition abs_nat_pp_pp :: "(nat, nat) pp  ('a, 'b) pp"
  where abs_nat_pp_pp_def [code del]: "abs_nat_pp_pp t = pp_of_fun (λn::'a. abs_nat (lookup_pp t (rep_nat n)))"

definition lex_comp'_pp :: "('a, 'b) pp comparator"
  where lex_comp'_pp_def [code del]: "lex_comp'_pp = comp_of_ord lex_pp"

definition deg'_pp :: "('a, 'b) pp  nat"
  where "deg'_pp x = rep_nat (deg_pp x)"

lemma lookup_rep_nat_pp_pp:
  "lookup_pp (rep_nat_pp t) = (λn::nat. rep_nat (lookup_pp t (abs_nat n)))"
  unfolding rep_nat_pp_pp_def
proof (rule lookup_pp_of_fun)
  have "{n. lookup_pp t (abs_nat n)  0}  rep_nat ` {x. lookup_pp t x  0}"
  proof
    fix n
    have "n = rep_nat (abs_nat n)" by (simp only: nat_class.abs_inverse)
    assume "n  {n. lookup_pp t (abs_nat n)  0}"
    hence "abs_nat n  {x. lookup_pp t x  0}" by simp
    with n = rep_nat (abs_nat n) show "n  rep_nat ` {x. lookup_pp t x  0}" ..
  qed
  also have "finite ..." by (rule finite_imageI, transfer, simp)
  also (finite_subset) have "{n. lookup_pp t (abs_nat n)  0} = {n. rep_nat (lookup_pp t (abs_nat n))  0}"
    by (metis rep_inj rep_zero)
  finally show "finite {x. rep_nat (lookup_pp t (abs_nat x))  0}" .
qed

lemma lookup_abs_nat_pp_pp:
  "lookup_pp (abs_nat_pp t) = (λn::'a. abs_nat (lookup_pp t (rep_nat n)))"
  unfolding abs_nat_pp_pp_def
proof (rule lookup_pp_of_fun)
  have "{n::'a. lookup_pp t (rep_nat n)  0}  abs_nat ` {x. lookup_pp t x  0}"
  proof
    fix n :: 'a
    have "n = abs_nat (rep_nat n)" by (simp only: nat_class.rep_inverse)
    assume "n  {n. lookup_pp t (rep_nat n)  0}"
    hence "rep_nat n  {x. lookup_pp t x  0}" by simp
    with n = abs_nat (rep_nat n) show "n  abs_nat ` {x. lookup_pp t x  0}" ..
  qed
  also have "finite ..." by (rule finite_imageI, transfer, simp)
  also (finite_subset) have "{n::'a. lookup_pp t (rep_nat n)  0} = {n. abs_nat (lookup_pp t (rep_nat n))  0}"
    by (metis abs_inverse abs_zero)
  finally show "finite {n::'a. abs_nat (lookup_pp t (rep_nat n))  0}" .
qed

lemma keys_rep_nat_pp_pp: "keys_pp (rep_nat_pp t) = rep_nat ` keys_pp t"
  by (rule set_eqI,
      simp add: keys_pp_iff lookup_rep_nat_pp_pp image_iff Bex_def ex_iff_abs[where 'a='a] rep_zero_iff del: neq0_conv)

lemma rep_nat_pp_pp_inverse: "abs_nat_pp (rep_nat_pp x) = x" for x::"('a, 'b) pp"
  by (rule pp_eqI, simp add: lookup_abs_nat_pp_pp lookup_rep_nat_pp_pp)

lemma abs_nat_pp_pp_inverse: "rep_nat_pp ((abs_nat_pp t)::('a, 'b) pp) = t"
  by (rule pp_eqI, simp add: lookup_abs_nat_pp_pp lookup_rep_nat_pp_pp)

corollary rep_nat_pp_pp_inj:
  fixes x y :: "('a, 'b) pp"
  assumes "rep_nat_pp x = rep_nat_pp y"
  shows "x = y"
  by (metis (no_types) rep_nat_pp_pp_inverse assms)

corollary rep_nat_pp_pp_eq_iff: "(rep_nat_pp x = rep_nat_pp y)  (x = y)" for x y :: "('a, 'b) pp"
  by (auto elim: rep_nat_pp_pp_inj)

lemma lex_rep_nat_pp: "lex_pp (rep_nat_pp x) (rep_nat_pp y)  lex_pp x y"
  by (simp add: lex_pp_alt rep_nat_pp_pp_eq_iff lookup_rep_nat_pp_pp rep_eq_iff
      ord_iff[symmetric] ex_iff_abs[where 'a='a] all_iff_abs')

corollary lex_comp'_pp: "lex_comp' x y = comp_of_ord lex_pp (rep_nat_pp x) (rep_nat_pp y)" for x y :: "('a, 'b) pp"
  by (simp add: lex_comp'_pp_def comp_of_ord_def rep_nat_pp_pp_eq_iff lex_rep_nat_pp)

corollary le_pp_pp: "rep_nat_pp x  rep_nat_pp y  x  y" for x y :: "('a, 'b) pp"
  by (simp only: less_eq_pp_def lex_rep_nat_pp)

lemma deg_rep_nat_pp: "deg_pp (rep_nat_pp t) = rep_nat (deg_pp t)" for t :: "('a, 'b) pp"
proof -
  have "keys_pp (rep_nat_pp t) = rep_nat ` keys_pp t"
    by (rule set_eqI, simp add: keys_pp_iff image_iff lookup_rep_nat_pp_pp Bex_def ex_iff_abs[where 'a='a] rep_zero_iff del: neq0_conv)
  hence "deg_pp (rep_nat_pp t) = sum (lookup_pp (rep_nat_pp t)) (rep_nat ` keys_pp t)"
    by (simp add: deg_pp_alt)
  also have "... = sum (lookup_pp (rep_nat_pp t)  rep_nat) (keys_pp t)"
    by (rule sum.reindex, rule inj_onI, elim rep_inj)
  also have "... = sum (rep_nat  (lookup_pp t)) (keys_pp t)"
    by (simp add: lookup_rep_nat_pp_pp)
  also have "... = rep_nat (deg_pp t)" by (simp only: deg_pp_alt sum_rep)
  finally show ?thesis .
qed

corollary deg'_pp: "deg' t = deg_pp (rep_nat_pp t)" for t :: "('a, 'b) pp"
  by (simp add: deg'_pp_def deg_rep_nat_pp)

lemma zero_pp_pp: "rep_nat_pp (0::('a, 'b) pp) = 0"
  by (rule pp_eqI, simp add: lookup_rep_nat_pp_pp)

lemma plus_pp_pp: "rep_nat_pp (x + y) = rep_nat_pp x + rep_nat_pp y"
  for x y :: "('a, 'b) pp"
  by (rule pp_eqI, simp add: lookup_rep_nat_pp_pp lookup_plus_pp rep_plus)

instance
  apply intro_classes
  subgoal by (fact rep_nat_pp_pp_inverse)
  subgoal by (fact abs_nat_pp_pp_inverse)
  subgoal by (fact lex_comp'_pp)
  subgoal by (fact deg'_pp)
  subgoal by (rule le_pp_pp)
  subgoal by (fact zero_pp_pp)
  subgoal by (fact plus_pp_pp)
  done

end

instantiation pp :: (nat, nat) nat_term
begin

definition rep_nat_term_pp :: "('a, 'b) pp  (nat, nat) pp × nat"
  where rep_nat_term_pp_def [code del]: "rep_nat_term_pp t = (rep_nat_pp t, 0)"

definition splus_pp :: "('a, 'b) pp  ('a, 'b) pp  ('a, 'b) pp"
  where splus_pp_def [code del]: "splus_pp = (+)"

instance proof
  fix x y :: "('a, 'b) pp"
  assume "rep_nat_term x = rep_nat_term y"
  hence "rep_nat_pp x = rep_nat_pp y" by (simp add: rep_nat_term_pp_def)
  thus "x = y" by (rule rep_nat_pp_pp_inj)
next
  fix x::"('a, 'b) pp" and i t
  assume "snd (rep_nat_term x) = i"
  hence "i = 0" by (simp add: rep_nat_term_pp_def)
  show "y::('a, 'b) pp. rep_nat_term y = (t, i)" unfolding i = 0
  proof
    show "rep_nat_term ((abs_nat_pp t)::('a, 'b) pp) = (t, 0)" by (simp add: rep_nat_term_pp_def)
  qed
next
  fix x y :: "('a, 'b) pp"
  show "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
    by (simp add: splus_pp_def rep_nat_term_pp_def pprod.splus_def plus_pp_pp)
qed

end

instantiation pp :: (nat, nat) nat_term_compare
begin

definition is_scalar_pp :: "('a, 'b) pp itself  bool"
  where is_scalar_pp_def [code_unfold]: "is_scalar_pp = (λ_. True)"

definition lex_comp_pp :: "('a, 'b) pp comparator"
  where lex_comp_pp_def [code_unfold]: "lex_comp_pp = lex_comp'"

definition deg_comp_pp :: "('a, 'b) pp comparator  ('a, 'b) pp comparator"
  where deg_comp_pp_def: "deg_comp_pp cmp = (λx y. case comparator_of (deg_pp x) (deg_pp y) of Eq  cmp x y | val  val)"

definition pot_comp_pp :: "('a, 'b) pp comparator  ('a, 'b) pp comparator"
  where pot_comp_pp_def [code_unfold]: "pot_comp_pp = (λcmp. cmp)"

instance proof
  show "x::('a, 'b) pp. snd (rep_nat_term x) = 0"
  proof
    show "snd (rep_nat_term (0::('a, 'b) pp)) = 0" by (simp add: rep_nat_term_pp_def)
  qed
next
  show "is_scalar = (λ_::('a, 'b) pp itself. x::('a, 'b) pp. snd (rep_nat_term x) = 0)"
    by (simp add: is_scalar_pp_def rep_nat_term_pp_def)
next
  show "lex_comp = (lex_comp_aux::('a, 'b) pp comparator)"
    by (auto simp: lex_comp_pp_def lex_comp_aux_def rep_nat_term_pp_def lex_comp'_pp split: order.split intro!: ext)
next
  fix cmp :: "('a, 'b) pp comparator"
  show "deg_comp cmp =
         (λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq  cmp x y
                      | Lt  Lt | Gt  Gt)"
    by (simp add: rep_nat_term_pp_def deg_comp_pp_def deg_rep_nat_pp comparator_of_rep)
next
  fix cmp :: "('a, 'b) pp comparator"
  show "pot_comp cmp =
         (λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq  cmp x y | Lt  Lt | Gt  Gt)"
    by (simp add: rep_nat_term_pp_def pot_comp_pp_def)
next
  fix x y :: "('a, 'b) pp"
  assume "rep_nat_term x  rep_nat_term y"
  hence "rep_nat_pp x  rep_nat_pp y" by (auto simp: rep_nat_term_pp_def)
  thus "x  y" by (rule le_pp_pp)
qed

end

instance pp :: (nat, nat) nat_pp_term
proof
  show "rep_nat_term (0::('a, 'b) pp) = (0, 0)"
    by (simp add: rep_nat_term_pp_def) (metis deg_pp_eq_0_iff deg_rep_nat_pp rep_zero)
next
  show "splus = ((+)::('a, 'b) pp  _)" by (simp add: splus_pp_def)
qed

instantiation prod :: ("{nat_pp_compare, comm_powerprod}", nat) nat_term
begin

definition rep_nat_term_prod :: "('a × 'b)  ((nat, nat) pp × nat)"
  where rep_nat_term_prod_def [code del]: "rep_nat_term_prod u = (rep_nat_pp (fst u), rep_nat (snd u))"

definition splus_prod :: "('a × 'b)  ('a × 'b)  ('a × 'b)"
  where splus_prod_def [code del]: "splus_prod t u = pprod.splus (fst t) u"

instance proof
  fix x y :: "'a × 'b"
  assume "rep_nat_term x = rep_nat_term y"
  hence 1: "rep_nat_pp (fst x) = rep_nat_pp (fst y)" and 2: "rep_nat (snd x) = rep_nat (snd y)"
    by (simp_all add: rep_nat_term_prod_def)
  from 1 have "fst x = fst y" by (rule rep_nat_pp_inj)
  moreover from 2 have "snd x = snd y" by (rule rep_inj)
  ultimately show "x = y" by (rule prod_eqI)
next
  fix i t
  show "y::'a × 'b. rep_nat_term y = (t, i)"
  proof
    show "rep_nat_term (abs_nat_pp t, abs_nat i) = (t, i)" by (simp add: rep_nat_term_prod_def)
  qed
next
  fix x y :: "'a × 'b"
  show "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
    by (simp add: splus_prod_def rep_nat_term_prod_def pprod.splus_def plus_pp)
qed

end

instantiation prod :: ("{nat_pp_compare, comm_powerprod}", nat) nat_term_compare
begin

definition is_scalar_prod :: "('a × 'b) itself  bool"
  where is_scalar_prod_def [code_unfold]: "is_scalar_prod = (λ_. False)"

definition lex_comp_prod :: "('a × 'b) comparator"
  where "lex_comp_prod = (λu v. case lex_comp' (fst u) (fst v) of Eq  comparator_of (snd u) (snd v) | val  val)"

definition deg_comp_prod :: "('a × 'b) comparator  ('a × 'b) comparator"
  where deg_comp_prod_def: "deg_comp_prod cmp = (λx y. case comparator_of (deg' (fst x)) (deg' (fst y)) of Eq  cmp x y | val  val)"

definition pot_comp_prod :: "('a × 'b) comparator  ('a × 'b) comparator"
  where "pot_comp_prod cmp = (λu v. case comparator_of (snd u) (snd v) of Eq  cmp u v | val  val)"

instance proof
  show "x::'a × 'b. snd (rep_nat_term x) = 0"
  proof
    show "snd (rep_nat_term (abs_nat_pp 0, 0)) = 0" by (simp add: rep_nat_term_prod_def)
  qed
next
  have "¬ (a. rep_nat (a::'b) = 0)"
  proof
    assume "a. rep_nat (a::'b) = 0"
    hence "rep_nat ((abs_nat 1)::'b) = 0" by blast
    hence "((abs_nat 1)::'b) = 0" by (simp only: rep_zero_iff)
    hence "(1::nat) = 0" by (metis abs_inj abs_zero)
    thus False by simp
  qed
  thus "is_scalar = (λ_::('a × 'b) itself. x. snd (rep_nat_term (x::'a × 'b)) = 0)"
    by (auto simp add: is_scalar_prod_def rep_nat_term_prod_def intro!: ext)
next
  show "lex_comp = (lex_comp_aux::('a × 'b) comparator)"
    by (auto simp: lex_comp_prod_def lex_comp_aux_def rep_nat_term_prod_def lex_comp' comparator_of_rep split: order.split intro!: ext)
next
  fix cmp :: "('a × 'b) comparator"
  show "deg_comp cmp =
         (λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq  cmp x y
                   | Lt  Lt | Gt  Gt)"
    by (simp add: rep_nat_term_prod_def deg_comp_prod_def deg')
next
  fix cmp :: "('a × 'b) comparator"
  show "pot_comp cmp =
         (λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq  cmp x y | Lt  Lt | Gt  Gt)"
    by (simp add: rep_nat_term_prod_def pot_comp_prod_def comparator_of_rep)
next
  fix x y :: "'a × 'b"
  assume "rep_nat_term x  rep_nat_term y"
  hence "rep_nat_pp (fst x) < rep_nat_pp (fst y)  (rep_nat_pp (fst x)  rep_nat_pp (fst y)  rep_nat (snd x)  rep_nat (snd y))"
    by (simp add: rep_nat_term_prod_def)
  thus "x  y" by (auto simp: less_eq_prod_def ord_iff[symmetric] intro: le_pp less_pp)
qed

end

lemmas [code del] = deg_pp.rep_eq plus_pp.abs_eq minus_pp.abs_eq

lemma rep_nat_pp_nat [code_unfold]: "(rep_nat_pp::(nat, nat) pp  (nat, nat) pp) = (λx. x)"
  by (intro ext pp_eqI, simp add: lookup_rep_nat_pp_pp abs_nat_nat_def rep_nat_nat_def)

subsubsection LEX›, DRLEX›, DEG› and POT›

definition LEX :: "'a::nat_term_compare nat_term_order" where "LEX = Abs_nat_term_order lex_comp"

definition DRLEX :: "'a::nat_term_compare nat_term_order"
  where "DRLEX = Abs_nat_term_order (deg_comp (pot_comp (λx y. lex_comp y x)))"

definition DEG :: "'a::nat_term_compare nat_term_order  'a nat_term_order"
  where "DEG to = Abs_nat_term_order (deg_comp (nat_term_compare to))"

definition POT :: "'a::nat_term_compare nat_term_order  'a nat_term_order"
  where "POT to = Abs_nat_term_order (pot_comp (nat_term_compare to))"

text @{const DRLEX} must apply @{const pot_comp}, for otherwise it does not satisfy
  the second condition of @{const nat_term_comp}.›

text ‹Instead of @{const DRLEX} one could also introduce another unary constructor DEGREV›, analogous
  to @{const DEG} and @{const POT}. Then, however, proving (in)equalities of the term orders gets
  really messy (think of @{prop "DEG (POT to) = DEGREV (DEGREV to)"}, for instance).
  So, we restrict the formalization to @{const DRLEX} only.›

abbreviation "DLEX  DEG LEX"

code_datatype LEX DRLEX DEG POT

lemma nat_term_compare_LEX [code]: "nat_term_compare LEX = lex_comp"
  unfolding LEX_def using comparator_lex_comp nat_term_comp_lex_comp
  by (rule nat_term_compare_Abs_nat_term_order_id)

lemma nat_term_compare_DRLEX [code]: "nat_term_compare DRLEX = deg_comp (pot_comp (λx y. lex_comp y x))"
proof -
  have cmp: "comparator (pot_comp (λx y. lex_comp y x))"
    by (rule comparator_pot_comp, rule comparator_converse, fact comparator_lex_comp)
  show ?thesis unfolding DRLEX_def
  proof (rule nat_term_compare_Abs_nat_term_order_id)
    from cmp show "comparator (deg_comp (pot_comp (λx y::'a. lex_comp y x)))"
      by (rule comparator_deg_comp)
  next
    show "nat_term_comp (deg_comp (pot_comp (λx y::'a. lex_comp y x)))"
    proof (rule nat_term_compI)
      fix u v :: 'a
      assume "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
      with cmp show "deg_comp (pot_comp (λx y::'a. lex_comp y x)) u v  Gt"
        by (rule deg_comp_zero_min)
    next
      fix u v :: 'a
      assume "snd (rep_nat_term u) < snd (rep_nat_term v)"
      hence "pot_comp (λx y. lex_comp y x) u v = Lt" by (rule pot_comp_pos)
      moreover assume "fst (rep_nat_term u) = fst (rep_nat_term v)"
      ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt" by (rule deg_comp_pos)
    next
      fix t u v :: 'a
      have "pot_comp (λx y. lex_comp y x) (splus t u) (splus t v) = Lt"
        if "pot_comp (λx y. lex_comp y x) u v = Lt" using _ that
      proof (rule pot_comp_monotone)
        assume "lex_comp v u = Lt"
        with nat_term_comp_lex_comp show "lex_comp (splus t v) (splus t u) = Lt"
          by (rule nat_term_compD3)
      qed
      moreover assume "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt"
      ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) (splus t u) (splus t v) = Lt"
        by (rule deg_comp_monotone)
    next
      fix u v a b :: 'a
      assume "fst (rep_nat_term v) = fst (rep_nat_term b)" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
        and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
      moreover from comparator_lex_comp nat_term_comp_lex_comp this(1, 2) this(3, 4)[symmetric]
      have "lex_comp v u = lex_comp b a" by (rule nat_term_compD4')
      moreover assume "deg_comp (pot_comp (λx y. lex_comp y x)) a b = Lt"
      ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt"
        by (simp add: deg_comp pot_comp split: order.splits)
    qed
  qed
qed

lemma nat_term_compare_DEG [code]: "nat_term_compare (DEG to) = deg_comp (nat_term_compare to)"
  unfolding DEG_def
proof (rule nat_term_compare_Abs_nat_term_order_id)
  from comparator_nat_term_compare show "comparator (deg_comp (nat_term_compare to))"
    by (rule comparator_deg_comp)
next
  show "nat_term_comp (deg_comp (nat_term_compare to))"
  proof (rule nat_term_compI)
    fix u v :: 'a
    assume "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
    with comparator_nat_term_compare show "deg_comp (nat_term_compare to) u v  Gt"
      by (rule deg_comp_zero_min)
  next
    fix u v :: 'a
    assume a: "fst (rep_nat_term u) = fst (rep_nat_term v)" and "snd (rep_nat_term u) < snd (rep_nat_term v)"
    with nat_term_comp_nat_term_compare have "nat_term_compare to u v = Lt" by (rule nat_term_compD2)
    thus "deg_comp (nat_term_compare to) u v = Lt" using a by (rule deg_comp_pos)
  next
    fix t u v :: 'a
    from nat_term_comp_nat_term_compare
    have "nat_term_compare to u v = Lt  nat_term_compare to (splus t u) (splus t v) = Lt"
      by (rule nat_term_compD3)
    moreover assume "deg_comp (nat_term_compare to) u v = Lt"
    ultimately show "deg_comp (nat_term_compare to) (splus t u) (splus t v) = Lt" by (rule deg_comp_monotone)
  next
    fix u v a b :: 'a
    assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
      and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
    moreover from comparator_nat_term_compare nat_term_comp_nat_term_compare this
    have "nat_term_compare to u v = nat_term_compare to a b"
      by (rule nat_term_compD4')
    moreover assume "deg_comp (nat_term_compare to) a b = Lt"
    ultimately show "deg_comp (nat_term_compare to) u v = Lt"
      by (simp add: deg_comp split: order.splits)
  qed
qed

lemma nat_term_compare_POT [code]: "nat_term_compare (POT to) = pot_comp (nat_term_compare to)"
  unfolding POT_def
proof (rule nat_term_compare_Abs_nat_term_order_id)
  from comparator_nat_term_compare show "comparator (pot_comp (nat_term_compare to))"
    by (rule comparator_pot_comp)
next
  show "nat_term_comp (pot_comp (nat_term_compare to))"
  proof (rule nat_term_compI)
    fix u v :: 'a
    assume a: "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
    with nat_term_comp_nat_term_compare have "nat_term_compare to u v  Gt" by (rule nat_term_compD1)
    thus "pot_comp (nat_term_compare to) u v  Gt" using a by (rule pot_comp_zero_min)
  next
    fix u v :: 'a
    assume "snd (rep_nat_term u) < snd (rep_nat_term v)"
    thus "pot_comp (nat_term_compare to) u v = Lt" by (rule pot_comp_pos)
  next
    fix t u v :: 'a
    from nat_term_comp_nat_term_compare
    have "nat_term_compare to u v = Lt  nat_term_compare to (splus t u) (splus t v) = Lt"
      by (rule nat_term_compD3)
    moreover assume "pot_comp (nat_term_compare to) u v = Lt"
    ultimately show "pot_comp (nat_term_compare to) (splus t u) (splus t v) = Lt" by (rule pot_comp_monotone)
  next
    fix u v a b :: 'a
    assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
      and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
    moreover from comparator_nat_term_compare nat_term_comp_nat_term_compare this
    have "nat_term_compare to u v = nat_term_compare to a b"
      by (rule nat_term_compD4')
    moreover assume "pot_comp (nat_term_compare to) a b = Lt"
    ultimately show "pot_comp (nat_term_compare to) u v = Lt"
      by (simp add: pot_comp split: order.splits)
  qed
qed

lemma nat_term_compare_POT_DRLEX [code]:
  "nat_term_compare (POT DRLEX) = pot_comp (deg_comp (λx y. lex_comp y x))"
  unfolding nat_term_compare_POT nat_term_compare_DRLEX
  by (intro ext pot_comp_cong deg_comp_cong, simp add: pot_comp)

lemma compute_lex_pp [code]: "lex_pp p q = (lex_comp' p q  Gt)"
  by (simp add: lex_comp'_pp_def comp_of_ord_def)

lemma compute_dlex_pp [code]: "dlex_pp p q = (deg_comp lex_comp' p q  Gt)"
  by (simp add: deg_comp_pp_def dlex_pp_alt compute_lex_pp comparator_of_def)

lemma compute_drlex_pp [code]: "drlex_pp p q = (deg_comp (λx y. lex_comp' y x) p q  Gt)"
  by (simp add: deg_comp_pp_def drlex_pp_alt compute_lex_pp comparator_of_def)

lemma nat_pp_order_of_le_nat_pp [code]: "nat_term_order_of_le = LEX"
  by (simp add: nat_term_order_of_le_def LEX_def lex_comp_alt)

subsubsection ‹Equality of Term Orders›

definition nat_term_order_eq :: "'a nat_term_order  'a::nat_term_compare nat_term_order  bool  bool  bool"
  where nat_term_order_eq_def [code del]:
      "nat_term_order_eq to1 to2 dg ps =
                (u v. (dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))) 
                       (ps  snd (rep_nat_term u) = snd (rep_nat_term v)) 
                       nat_term_compare to1 u v = nat_term_compare to2 u v)"

lemma nat_term_order_eqI:
  assumes "u v. (dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))) 
                  (ps  snd (rep_nat_term u) = snd (rep_nat_term v)) 
                  nat_term_compare to1 u v = nat_term_compare to2 u v"
  shows "nat_term_order_eq to1 to2 dg ps"
  unfolding nat_term_order_eq_def using assms by blast

lemma nat_term_order_eqD:
  assumes "nat_term_order_eq to1 to2 dg ps"
    and "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
    and "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
  shows "nat_term_compare to1 u v = nat_term_compare to2 u v"
  using assms unfolding nat_term_order_eq_def by blast

lemma nat_term_order_eq_sym: "nat_term_order_eq to1 to2 dg ps  nat_term_order_eq to2 to1 dg ps"
  by (auto simp: nat_term_order_eq_def)

lemma nat_term_order_eq_DEG_dg:
  "nat_term_order_eq (DEG to1) to2 True ps  nat_term_order_eq to1 to2 True ps"
  by (auto simp: nat_term_order_eq_def nat_term_compare_DEG deg_comp)

lemma nat_term_order_eq_DEG_dg':
  "nat_term_order_eq to1 (DEG to2) True ps  nat_term_order_eq to1 to2 True ps"
  by (simp add: nat_term_order_eq_sym[of to1] nat_term_order_eq_DEG_dg)

lemma nat_term_order_eq_POT_ps:
  assumes "ps  is_scalar TYPE('a::nat_term_compare)"
  shows "nat_term_order_eq (POT (to1::'a nat_term_order)) to2 dg ps  nat_term_order_eq to1 to2 dg ps"
  using assms
proof
  assume "ps"
  thus ?thesis by (auto simp: nat_term_order_eq_def nat_term_compare_POT pot_comp)
next
  assume "is_scalar TYPE('a)"
  hence "snd (rep_nat_term x) = 0" for x::'a by (simp add: is_scalar)
  thus ?thesis by (auto simp: nat_term_order_eq_def nat_term_compare_POT pot_comp)
qed

lemma nat_term_order_eq_POT_ps':
  assumes "ps  is_scalar TYPE('a::nat_term_compare)"
  shows "nat_term_order_eq to1 (POT (to2::'a nat_term_order)) dg ps  nat_term_order_eq to1 to2 dg ps"
  using assms by (simp add: nat_term_order_eq_sym[of to1] nat_term_order_eq_POT_ps)

lemma snd_rep_nat_term_eqI:
  assumes "ps  is_scalar TYPE('a::nat_term_compare)" and "ps  snd (rep_nat_term (u::'a)) = snd (rep_nat_term (v::'a))"
  shows "snd (rep_nat_term u) = snd (rep_nat_term v)"
  using assms(1)
proof
  assume "is_scalar TYPE('a)"
  thus ?thesis by (simp add: is_scalar)
qed (fact assms(2))

definition of_exps :: "nat  nat  nat  'a::nat_term_compare"
  where "of_exps a b i =
        (THE u. rep_nat_term u = (pp_of_fun (λx. if x = 0 then a else if x = 1 then b else 0),
                                  if (v::'a. snd (rep_nat_term v) = i) then i else 0))"

text @{const of_exps} is an auxiliary function needed for proving the equalities of the various
  term orders.›

lemma rep_nat_term_of_exps:
  "rep_nat_term ((of_exps a b i)::'a::nat_term_compare) =
    (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), if (y::'a. snd (rep_nat_term y) = i) then i else 0)"
proof (cases "y::'a. snd (rep_nat_term y) = i")
  case True
  then obtain y::'a where "snd (rep_nat_term y) = i" ..
  then obtain u::'a where u: "rep_nat_term u = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), i)"
    by (rule full_componentE)
  from True have eq: "(if y::'a. snd (rep_nat_term y) = i then i else 0) = i" by simp
  show ?thesis unfolding of_exps_def eq
  proof (rule theI)
    fix v :: 'a
    assume "rep_nat_term v = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), i)"
    thus "v = u" unfolding u[symmetric] by (rule rep_nat_term_inj)
  qed (fact u)
next
  case False
  hence eq: "(if y::'a. snd (rep_nat_term y) = i then i else 0) = 0" by simp
  obtain u::'a where u: "rep_nat_term u = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), 0)"
    by (rule full_component_zeroE)
  show ?thesis unfolding of_exps_def eq
  proof (rule theI)
    fix v :: 'a
    assume "rep_nat_term v = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), 0)"
    thus "v = u" unfolding u[symmetric] by (rule rep_nat_term_inj)
  qed (fact u)
qed

lemma lookup_pp_of_exps:
  "lookup_pp (fst (rep_nat_term (of_exps a b i))) = (λx. if x = 0 then a else if x = 1 then b else 0)"
  unfolding rep_nat_term_of_exps fst_conv
proof (rule lookup_pp_of_fun)
  have "{x. (if x = 0 then a else if x = 1 then b else 0)  0}  {0, 1}"
    by (rule, simp split: if_split_asm)
  also have "finite ..." by simp
  finally(finite_subset) show "finite {x. (if x = 0 then a else if x = 1 then b else 0)  0}" .
qed

lemma keys_pp_of_exps: "keys_pp (fst (rep_nat_term (of_exps a b i)))  {0, 1}"
  by (rule, simp add: keys_pp_iff lookup_pp_of_exps split: if_split_asm)

lemma deg_pp_of_exps [simp]: "deg_pp (fst (rep_nat_term ((of_exps a b i)::'a::nat_term_compare))) = a + b"
proof -
  let ?u = "(of_exps a b i)::'a"
  have "sum (lookup_pp (fst (rep_nat_term ?u))) (keys_pp (fst (rep_nat_term ?u))) =
        sum (lookup_pp (fst (rep_nat_term ?u))) {0, 1}"
  proof (rule sum.mono_neutral_left, simp, fact keys_pp_of_exps, intro ballI)
    fix x
    assume "x  {0, 1} - keys_pp (fst (rep_nat_term ?u))"
    thus "lookup_pp (fst (rep_nat_term ?u)) x = 0" by (simp add: keys_pp_iff)
  qed
  also have "... = a + b" by (simp add: lookup_pp_of_exps)
  finally show ?thesis by (simp only: deg_pp_alt)
qed

lemma snd_of_exps:
  assumes "snd (rep_nat_term (x::'a)) = i"
  shows "snd (rep_nat_term ((of_exps a b i)::'a::nat_term_compare)) = i"
proof -
  from assms have "x::'a. snd (rep_nat_term (x::'a)) = i" ..
  thus ?thesis by (simp add: rep_nat_term_of_exps)
qed

lemma snd_of_exps_zero [simp]: "snd (rep_nat_term ((of_exps a b 0)::'a::nat_term_compare)) = 0"
proof -
  from zero_component obtain x::'a where "snd (rep_nat_term (x::'a)) = 0" ..
  thus ?thesis by (rule snd_of_exps)
qed

lemma eq_of_exps:
  "(fst (rep_nat_term (of_exps a1 b1 i)) = fst (rep_nat_term (of_exps a2 b2 j)))  (a1 = a2  b1 = b2)"
proof -
  have "a1 = a2  b1 = b2"
    if "(λx::nat. if x = 0 then a1 else if x = 1 then b1 else 0) = (λx. if x = 0 then a2 else if x = 1 then b2 else 0)"
  proof
    from fun_cong[OF that, of 0] show "a1 = a2" by simp
  next
    from fun_cong[OF that, of 1] show "b1 = b2" by simp
  qed
  thus ?thesis by (auto simp: pp_eq_iff lookup_pp_of_exps)
qed

lemma lex_pp_of_exps:
  "lex_pp (fst (rep_nat_term ((of_exps a1 b1 i)::'a))) (fst (rep_nat_term ((of_exps a2 b2 j)::'a::nat_term_compare))) 
    (a1 < a2  (a1 = a2  b1  b2))" (is "?L  ?R")
proof -
  let ?u = "fst (rep_nat_term ((of_exps a1 b1 i)::'a))"
  let ?v = "fst (rep_nat_term ((of_exps a2 b2 j)::'a))"
  show ?thesis
  proof
    assume ?L
    hence "?u = ?v  (x. lookup_pp ?u x < lookup_pp ?v x  (y<x. lookup_pp ?u y = lookup_pp ?v y))"
      by (simp only: lex_pp_alt)
    thus ?R
    proof
      assume "?u = ?v"
      thus ?thesis by (simp add: eq_of_exps)
    next
      assume "x. lookup_pp ?u x < lookup_pp ?v x  (y<x. lookup_pp ?u y = lookup_pp ?v y)"
      then obtain x where 1: "lookup_pp ?u x < lookup_pp ?v x" and 2: "y. y < x  lookup_pp ?u y = lookup_pp ?v y"
        by auto
      from 1 have "lookup_pp ?v x  0" by simp
      hence "x  keys_pp ?v" by (simp add: keys_pp_iff)
      also have "...  {0, 1}" by (fact keys_pp_of_exps)
      finally have "x = 0  x = 1" by simp
      thus ?thesis
      proof
        assume "x = 0"
        from 1 show ?thesis by (simp add: lookup_pp_of_exps x = 0)
      next
        assume "x = 1"
        hence "0 < x" by simp
        hence "lookup_pp ?u 0 = lookup_pp ?v 0" by (rule 2)
        hence "a1 = a2" by (simp add: lookup_pp_of_exps)
        from 1 show ?thesis by (simp add: lookup_pp_of_exps x = 1 a1 = a2)
      qed
    qed
  next
    assume ?R
    thus ?L
    proof
      assume "a1 < a2"
      show ?thesis unfolding lex_pp_alt
      proof (intro disjI2 exI conjI allI impI)
        from a1 < a2 show "lookup_pp ?u 0 < lookup_pp ?v 0" by (simp add: lookup_pp_of_exps)
      next
        fix y::nat
        assume "y < 0"
        thus "lookup_pp ?u y = lookup_pp ?v y" by simp
      qed
    next
      assume "a1 = a2  b1  b2"
      hence "a1 = a2" and "b1  b2" by simp_all
      from this(2) have "b1 < b2  b1 = b2" by auto
      thus ?thesis
      proof
        assume "b1 < b2"
        show ?thesis unfolding lex_pp_alt
        proof (intro disjI2 exI conjI allI impI)
          from b1 < b2 show "lookup_pp ?u 1 < lookup_pp ?v 1" by (simp add: lookup_pp_of_exps)
        next
          fix y::nat
          assume "y < 1"
          hence "y = 0" by simp
          show "lookup_pp ?u y = lookup_pp ?v y" by (simp add: lookup_pp_of_exps y = 0 a1 = a2)
        qed
      next
        assume "b1 = b2"
        show ?thesis by (simp add: lex_pp_alt eq_of_exps a1 = a2 b1 = b2)
      qed
    qed
  qed
qed

lemma LEX_eq [code]:
  "nat_term_order_eq LEX (LEX::'a nat_term_order) dg ps = True" (is ?thesis1)
  "nat_term_order_eq LEX (DRLEX::'a nat_term_order) dg ps = False" (is ?thesis2)
  "nat_term_order_eq LEX (DEG (to::'a nat_term_order)) dg ps =
    (dg  nat_term_order_eq LEX to dg ps)" (is ?thesis3)
  "nat_term_order_eq LEX (POT (to::'a nat_term_order)) dg ps =
    ((ps  is_scalar TYPE('a::nat_term_compare))  nat_term_order_eq LEX to dg ps)" (is ?thesis4)
proof -
  show ?thesis1 by (simp add: nat_term_order_eq_def)
next
  show ?thesis2
  proof (intro iffI)
    assume a: "nat_term_order_eq LEX (DRLEX::'a nat_term_order) dg ps"
    let ?u = "(of_exps 0 1 0)::'a"
    let ?v = "(of_exps 1 0 0)::'a"
    have "nat_term_compare LEX ?u ?v = nat_term_compare DRLEX ?u ?v"
      by (rule nat_term_order_eqD, fact a, simp_all)
    thus False
      by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def nat_term_compare_DRLEX deg_comp
          pot_comp comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps)
  qed (rule FalseE)
next
  show ?thesis3
  proof (intro iffI)
    assume a: "nat_term_order_eq LEX (DEG to) dg ps"
    have dg
    proof (rule ccontr)
      assume "¬ dg"
      let ?u = "(of_exps 0 2 0)::'a"
      let ?v = "(of_exps 1 0 0)::'a"
      have "nat_term_compare LEX ?u ?v = nat_term_compare (DEG to) ?u ?v"
        by (rule nat_term_order_eqD, fact a, simp_all add: ¬ dg)
      thus False
        by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def nat_term_compare_DEG deg_comp
            comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps)
    qed
    show "dg  nat_term_order_eq LEX to dg ps"
    proof (intro conjI dg nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      from dg have eq: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
      assume "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with a 1 have "nat_term_compare LEX u v = nat_term_compare (DEG to) u v"
        by (rule nat_term_order_eqD)
      also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_DEG deg_comp eq)
      finally show "nat_term_compare LEX u v = nat_term_compare to u v" .
    qed
  next
    assume "dg  nat_term_order_eq LEX to dg ps"
    hence dg and a: "nat_term_order_eq LEX to dg ps" by auto
    show "nat_term_order_eq LEX (DEG to) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      from dg have eq: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
      assume "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with a 1 have "nat_term_compare LEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
      also have "... = nat_term_compare (DEG to) u v" by (simp add: nat_term_compare_DEG deg_comp eq)
      finally show "nat_term_compare LEX u v = nat_term_compare (DEG to) u v" .
    qed
  qed
next
  show ?thesis4
  proof (intro iffI)
    assume a: "nat_term_order_eq LEX (POT to) dg ps"
    have *: "ps  is_scalar TYPE('a)"
    proof (rule ccontr)
      assume "¬ (ps  is_scalar TYPE('a))"
      hence "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
      from this(2) obtain x::'a where "snd (rep_nat_term x)  0" unfolding is_scalar by auto
      moreover define i::nat where "i = snd (rep_nat_term x)"
      ultimately have "i  0" by simp
      let ?u = "(of_exps 0 1 i)::'a"
      let ?v = "(of_exps 1 0 0)::'a"
      from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
      have "nat_term_compare LEX ?u ?v = nat_term_compare (POT to) ?u ?v"
        by (rule nat_term_order_eqD, fact a, simp_all add: ¬ ps)
      thus False
        by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def pot_comp nat_term_compare_POT
            comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps eq i  0 del: One_nat_def)
    qed
    show "(ps  is_scalar TYPE('a))  nat_term_order_eq LEX to dg ps"
    proof (intro conjI * nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      assume 2: "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with * have eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" by (rule snd_rep_nat_term_eqI)
      from a 1 2 have "nat_term_compare LEX u v = nat_term_compare (POT to) u v"
        by (rule nat_term_order_eqD)
      also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_POT eq pot_comp)
      finally show "nat_term_compare LEX u v = nat_term_compare to u v" .
    qed
  next
    assume "(ps  is_scalar TYPE('a))  nat_term_order_eq LEX to dg ps"
    hence *: "ps  is_scalar TYPE('a)" and a: "nat_term_order_eq LEX to dg ps" by auto
    show "nat_term_order_eq LEX (POT to) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      assume 2: "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with * have eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" by (rule snd_rep_nat_term_eqI)
      from a 1 2 have "nat_term_compare LEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
      also have "... = nat_term_compare (POT to) u v" by (simp add: nat_term_compare_POT eq pot_comp)
      finally show "nat_term_compare LEX u v = nat_term_compare (POT to) u v" .
    qed
  qed
qed

lemma DRLEX_eq [code]:
  "nat_term_order_eq DRLEX (LEX::'a nat_term_order) dg ps = False" (is ?thesis1)
  "nat_term_order_eq DRLEX DRLEX dg ps = True" (is ?thesis2)
  "nat_term_order_eq DRLEX (DEG (to::'a nat_term_order)) dg ps =
    nat_term_order_eq DRLEX to True ps" (is ?thesis3)
  "nat_term_order_eq DRLEX (POT (to::'a nat_term_order)) dg ps =
    ((dg  ps  is_scalar TYPE('a::nat_term_compare))  nat_term_order_eq DRLEX to dg True)" (is ?thesis4)
proof -
  from nat_term_order_eq_sym[of "DRLEX::'a nat_term_order"] show ?thesis1 by (simp only: LEX_eq)
next
  show ?thesis2 by (simp add: nat_term_order_eq_def)
next
  show ?thesis3
  proof (intro iffI)
    assume a: "nat_term_order_eq DRLEX (DEG to) dg ps"
    show "nat_term_order_eq DRLEX to True ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "True  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
        and "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with a have "nat_term_compare DRLEX u v = nat_term_compare (DEG to) u v"
        by (rule nat_term_order_eqD, blast+)
      also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_DEG deg_comp 1)
      finally show "nat_term_compare DRLEX u v = nat_term_compare to u v" .
    qed
  next
    assume a: "nat_term_order_eq DRLEX to True ps"
    show "nat_term_order_eq DRLEX (DEG to) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      show "nat_term_compare DRLEX u v = nat_term_compare (DEG to) u v"
      proof (simp add: nat_term_compare_DRLEX nat_term_compare_DEG deg_comp comparator_of_def split: order.split, rule)
        assume 2: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
        with a have "nat_term_compare DRLEX u v = nat_term_compare to u v"
          using 1 by (rule nat_term_order_eqD)
        thus "pot_comp (λx y. lex_comp y x) u v = nat_term_compare to u v"
          by (simp add: nat_term_compare_DRLEX deg_comp 2)
      qed
    qed
  qed
next
  show ?thesis4
  proof (intro iffI)
    assume a: "nat_term_order_eq DRLEX (POT to) dg ps"
    have *: "dg  ps  is_scalar TYPE('a)"
    proof (rule ccontr)
      assume "¬ (dg  ps  is_scalar TYPE('a))"
      hence "¬ dg" and "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
      from this(3) obtain x::'a where "snd (rep_nat_term x)  0" unfolding is_scalar by auto
      moreover define i::nat where "i = snd (rep_nat_term x)"
      ultimately have "i  0" by simp
      let ?u = "(of_exps 1 0 i)::'a"
      let ?v = "(of_exps 2 0 0)::'a"
      from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
      have "nat_term_compare DRLEX ?u ?v = nat_term_compare (POT to) ?u ?v"
        by (rule nat_term_order_eqD, fact a, simp_all add: ¬ ps ¬ dg)
      thus False
        by (simp add: nat_term_compare_DRLEX deg_comp pot_comp nat_term_compare_POT
            comparator_of_def eq i  0 del: One_nat_def)
    qed
    show "(dg  ps  is_scalar TYPE('a))  nat_term_order_eq DRLEX to dg True"
    proof (intro conjI * nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      assume 2: "True  snd (rep_nat_term u) = snd (rep_nat_term v)"
      from a 1 2 have "nat_term_compare DRLEX u v = nat_term_compare (POT to) u v"
        by (rule nat_term_order_eqD, blast+)
      also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_POT 2 pot_comp)
      finally show "nat_term_compare DRLEX u v = nat_term_compare to u v" .
    qed
  next
    assume "(dg  ps  is_scalar TYPE('a))  nat_term_order_eq DRLEX to dg True"
    hence disj: "dg  ps  is_scalar TYPE('a)" and a: "nat_term_order_eq DRLEX to dg True" by auto
    show "nat_term_order_eq DRLEX (POT to) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume 1: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      assume 2: "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      from disj show "nat_term_compare DRLEX u v = nat_term_compare (POT to) u v"
      proof
        assume dg
        hence eq1: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
        show ?thesis
        proof (simp add: nat_term_compare_DRLEX deg_comp eq1 nat_term_compare_POT pot_comp comparator_of_def split: order.split, rule)
          assume eq2: "snd (rep_nat_term u) = snd (rep_nat_term v)"
          with a 1 have "nat_term_compare DRLEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
          thus "lex_comp v u = nat_term_compare to u v"
            by (simp add: nat_term_compare_DRLEX deg_comp eq1 pot_comp eq2)
        qed
      next
        assume "ps  is_scalar TYPE('a)"
        hence eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" using 2 by (rule snd_rep_nat_term_eqI)
        with a 1 have "nat_term_compare DRLEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
        also have "... = nat_term_compare (POT to) u v" by (simp add: nat_term_compare_POT pot_comp eq)
        finally show ?thesis .
      qed
    qed
  qed
qed

lemma DEG_eq [code]:
  "nat_term_order_eq (DEG to) (LEX::'a nat_term_order) dg ps = nat_term_order_eq LEX (DEG to) dg ps"
  "nat_term_order_eq (DEG to) (DRLEX::'a nat_term_order) dg ps = nat_term_order_eq DRLEX (DEG to) dg ps"
  "nat_term_order_eq (DEG to1) (DEG (to2::'a nat_term_order)) dg ps =
    nat_term_order_eq to1 to2 True ps" (is ?thesis3)
  "nat_term_order_eq (DEG to1) (POT (to2::'a nat_term_order)) dg ps =
    (if dg then nat_term_order_eq to1 (POT to2) dg ps
    else ((ps  is_scalar TYPE('a::nat_term_compare))  nat_term_order_eq (DEG to1) to2 dg ps))" (is ?thesis4)
proof -
  show ?thesis3
  proof (rule iffI)
    assume a: "nat_term_order_eq (DEG to1) (DEG to2) dg ps"
    show "nat_term_order_eq to1 to2 True ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume b: "True  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
        and "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with a have "nat_term_compare (DEG to1) u v = nat_term_compare (DEG to2) u v"
        by (rule nat_term_order_eqD, blast+)
      thus "nat_term_compare to1 u v = nat_term_compare to2 u v"
        by (simp add: nat_term_compare_DEG deg_comp comparator_of_def b)
    qed
  next
    assume a: "nat_term_order_eq to1 to2 True ps"
    show "nat_term_order_eq (DEG to1) (DEG to2) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume b: "ps  snd (rep_nat_term u) = snd (rep_nat_term v)"
      show "nat_term_compare (DEG to1) u v = nat_term_compare (DEG to2) u v"
      proof (simp add: nat_term_compare_DEG deg_comp comparator_of_def split: order.split, rule impI)
        assume "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
        with a show "nat_term_compare to1 u v = nat_term_compare to2 u v" using b by (rule nat_term_order_eqD)
      qed
    qed
  qed
next
  show ?thesis4
  proof (simp add: nat_term_order_eq_DEG_dg split: if_split, intro impI)
    show "nat_term_order_eq (DEG to1) (POT to2) False ps =
            ((ps  is_scalar TYPE('a))  nat_term_order_eq (DEG to1) to2 False ps)"
    proof (intro iffI)
      assume a: "nat_term_order_eq (DEG to1) (POT to2) False ps"
      have *: "ps  is_scalar TYPE('a)"
      proof (rule ccontr)
        assume "¬ (ps  is_scalar TYPE('a))"
        hence "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
        from this(2) obtain x::'a where "snd (rep_nat_term x)  0" unfolding is_scalar by auto
        moreover define i::nat where "i = snd (rep_nat_term x)"
        ultimately have "i  0" by simp
        let ?u = "(of_exps 1 0 i)::'a"
        let ?v = "(of_exps 2 0 0)::'a"
        from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
        have "nat_term_compare (DEG to1) ?u ?v = nat_term_compare (POT to2) ?u ?v"
          by (rule nat_term_order_eqD, fact a, simp_all add: ¬ ps)
        thus False
          by (simp add: nat_term_compare_DEG deg_comp pot_comp nat_term_compare_POT
              comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps eq i  0 del: One_nat_def)
      qed
      moreover from this a have "nat_term_order_eq (DEG to1) to2 False ps" by (simp add: nat_term_order_eq_POT_ps')
      ultimately show "(ps  is_scalar TYPE('a))  nat_term_order_eq (DEG to1) to2 False ps" ..
    qed (simp add: nat_term_order_eq_POT_ps')
  qed
qed (fact nat_term_order_eq_sym)+

lemma POT_eq [code]:
  "nat_term_order_eq (POT to) LEX dg ps = nat_term_order_eq LEX (POT to) dg ps"
  "nat_term_order_eq (POT to1) (DEG to2) dg ps = nat_term_order_eq (DEG to2) (POT to1) dg ps"
  "nat_term_order_eq (POT to1) DRLEX dg ps = nat_term_order_eq DRLEX (POT to1) dg ps"
  "nat_term_order_eq (POT to1) (POT (to2::'a::nat_term_compare nat_term_order)) dg ps =
    nat_term_order_eq to1 to2 dg True" (is ?thesis4)
proof -
  show ?thesis4
  proof (rule iffI)
    assume a: "nat_term_order_eq (POT to1) (POT to2) dg ps"
    show "nat_term_order_eq to1 to2 dg True"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
        and b: "True  snd (rep_nat_term u) = snd (rep_nat_term v)"
      with a have "nat_term_compare (POT to1) u v = nat_term_compare (POT to2) u v"
        by (rule nat_term_order_eqD, blast+)
      thus "nat_term_compare to1 u v = nat_term_compare to2 u v"
        by (simp add: nat_term_compare_POT pot_comp comparator_of_def b)
    qed
  next
    assume a: "nat_term_order_eq to1 to2 dg True"
    show "nat_term_order_eq (POT to1) (POT to2) dg ps"
    proof (rule nat_term_order_eqI)
      fix u v :: 'a
      assume b: "dg  deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
      show "nat_term_compare (POT to1) u v = nat_term_compare (POT to2) u v"
      proof (simp add: nat_term_compare_POT pot_comp comparator_of_def split: order.split, rule impI)
        assume "snd (rep_nat_term u) = snd (rep_nat_term v)"
        with a b show "nat_term_compare to1 u v = nat_term_compare to2 u v" by (rule nat_term_order_eqD)
      qed
    qed
  qed
qed (fact nat_term_order_eq_sym)+

lemma nat_term_order_equal [code]: "HOL.equal to1 to2 = nat_term_order_eq to1 to2 False False"
  by (auto simp: nat_term_order_eq_def equal_eq nat_term_compare_inject[symmetric])

hide_const (open) of_exps

value [code] "DEG (POT DRLEX) = (DRLEX::((nat, nat) pp × nat) nat_term_order)"

value [code] "POT LEX = (LEX::((nat, nat) pp × nat) nat_term_order)"

value [code] "POT LEX = (LEX::(nat, nat) pp nat_term_order)"

end (*theory*)

Theory MPoly_Type_Class_OAlist

(* Author: Fabian Immler, TU Muenchen *)
(* Author: Florian Haftmann, TU Muenchen *)
(* Author: Andreas Lochbihler, ETH Zurich *)
(* Author: Alexander Maletzky, RISC Linz *)

section ‹Executable Representation of Polynomial Mappings as Association Lists›

theory MPoly_Type_Class_OAlist
  imports Term_Order
begin

instantiation pp :: (type, "{equal, zero}") equal
begin

definition equal_pp :: "('a, 'b) pp  ('a, 'b) pp  bool" where
  "equal_pp p q  (t. lookup_pp p t = lookup_pp q t)"

instance by standard (auto simp: equal_pp_def intro: pp_eqI)

end

instantiation poly_mapping :: (type, "{equal, zero}") equal
begin

definition equal_poly_mapping :: "('a, 'b) poly_mapping  ('a, 'b) poly_mapping  bool" where
  equal_poly_mapping_def [code del]: "equal_poly_mapping p q  (t. lookup p t = lookup q t)"

instance by standard (auto simp: equal_poly_mapping_def intro: poly_mapping_eqI)

end

subsection ‹Power-Products Represented by @{type oalist_tc}

definition PP_oalist :: "('a::linorder, 'b::zero) oalist_tc  ('a, 'b) pp"
  where "PP_oalist xs = pp_of_fun (OAlist_tc_lookup xs)"

code_datatype PP_oalist

lemma lookup_PP_oalist [simp, code]: "lookup_pp (PP_oalist xs) = OAlist_tc_lookup xs"
  unfolding PP_oalist_def
proof (rule lookup_pp_of_fun)
  have "{x. OAlist_tc_lookup xs x  0}  fst ` set (list_of_oalist_tc xs)"
  proof (rule, simp)
    fix x
    assume "OAlist_tc_lookup xs x  0"
    thus "x  fst ` set (list_of_oalist_tc xs)"
      using in_OAlist_tc_sorted_domain_iff_lookup set_OAlist_tc_sorted_domain by blast
  qed
  also have "finite ..." by simp
  finally (finite_subset) show "finite {x. OAlist_tc_lookup xs x  0}" .
qed

lemma keys_PP_oalist [code]: "keys_pp (PP_oalist xs) = set (OAlist_tc_sorted_domain xs)"
  by (rule set_eqI, simp add: keys_pp_iff in_OAlist_tc_sorted_domain_iff_lookup)

lemma lex_comp_PP_oalist [code]:
  "lex_comp' (PP_oalist xs) (PP_oalist ys) =
         the (OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys)"
  for xs ys::"('a::nat, 'b::nat) oalist_tc"
proof (cases "lex_comp' (PP_oalist xs) (PP_oalist ys) = Eq")
  case True
  hence "PP_oalist xs = PP_oalist ys" by (rule lex_comp'_EqD)
  hence eq: "OAlist_tc_lookup xs = OAlist_tc_lookup ys" by (simp add: pp_eq_iff)
  have "OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys = Some Eq"
    by (rule OAlist_tc_lex_ord_EqI, simp add: eq)
  thus ?thesis by (simp add: True)
next
  case False
  then obtain x where 1: "x  keys_pp (rep_nat_pp (PP_oalist xs))  keys_pp (rep_nat_pp (PP_oalist ys))"
    and 2: "comparator_of (lookup_pp (rep_nat_pp (PP_oalist xs)) x) (lookup_pp (rep_nat_pp (PP_oalist ys)) x) =
          lex_comp' (PP_oalist xs) (PP_oalist ys)"
    and 3: "y. y < x  lookup_pp (rep_nat_pp (PP_oalist xs)) y = lookup_pp (rep_nat_pp (PP_oalist ys)) y"
    by (rule lex_comp'_valE, blast)
  have "OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys = Some (lex_comp' (PP_oalist xs) (PP_oalist ys))"
  proof (rule OAlist_tc_lex_ord_valI)
    from False show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys))  Some Eq" by simp
  next
    from 1 have "abs_nat x  abs_nat ` (keys_pp (rep_nat_pp (PP_oalist xs))  keys_pp (rep_nat_pp (PP_oalist ys)))"
      by (rule imageI)
    also have "... = fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)"
      by (simp add: keys_rep_nat_pp_pp keys_PP_oalist OAlist_tc_sorted_domain_def image_Un image_image)
    finally show "abs_nat x  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)" .
  next
    show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) =
          Some (comparator_of (OAlist_tc_lookup xs (abs_nat x)) (OAlist_tc_lookup ys (abs_nat x)))"
      by (simp add: 2[symmetric] lookup_rep_nat_pp_pp)
  next
    fix y::'a
    assume "y < abs_nat x"
    hence "rep_nat y < x" by (metis abs_inverse ord_iff(2))
    hence "lookup_pp (rep_nat_pp (PP_oalist xs)) (rep_nat y) = lookup_pp (rep_nat_pp (PP_oalist ys)) (rep_nat y)"
      by (rule 3)
    hence "OAlist_tc_lookup xs y = OAlist_tc_lookup ys y" by (auto simp: lookup_rep_nat_pp_pp elim: rep_inj)
    thus "Some (comparator_of (OAlist_tc_lookup xs y) (OAlist_tc_lookup ys y)) = Some Eq" by simp
  qed
  thus ?thesis by simp
qed

lemma zero_PP_oalist [code]: "(0::('a::linorder, 'b::zero) pp) = PP_oalist OAlist_tc_empty"
  by (rule pp_eqI, simp add: lookup_OAlist_tc_empty)

lemma plus_PP_oalist [code]:
  "PP_oalist xs + PP_oalist ys = PP_oalist (OAlist_tc_map2_val_neutr (λ_. (+)) xs ys)"
  by (rule pp_eqI, simp add: lookup_plus_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all)

lemma minus_PP_oalist [code]:
  "PP_oalist xs - PP_oalist ys = PP_oalist (OAlist_tc_map2_val_rneutr (λ_. (-)) xs ys)"
  by (rule pp_eqI, simp add: lookup_minus_pp, rule lookup_OAlist_tc_map2_val_rneutr[symmetric], simp)

lemma equal_PP_oalist [code]: "equal_class.equal (PP_oalist xs) (PP_oalist ys) = (xs = ys)"
  by (simp add: equal_eq pp_eq_iff, auto elim: OAlist_tc_lookup_inj)

lemma lcs_PP_oalist [code]:
  "lcs (PP_oalist xs) (PP_oalist ys) = PP_oalist (OAlist_tc_map2_val_neutr (λ_. max) xs ys)"
  for xs ys :: "('a::linorder, 'b::add_linorder_min) oalist_tc"
  by (rule pp_eqI, simp add: lookup_lcs_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all add: max_def)

lemma deg_pp_PP_oalist [code]: "deg_pp (PP_oalist xs) = sum_list (map snd (list_of_oalist_tc xs))"
proof -
  have "irreflp ((<)::_::linorder  _)" by (rule irreflpI, simp)
  have "deg_pp (PP_oalist xs) = sum (OAlist_tc_lookup xs) (set (OAlist_tc_sorted_domain xs))"
    by (simp add: deg_pp_alt keys_PP_oalist)
  also have "... = sum_list (map (OAlist_tc_lookup xs) (OAlist_tc_sorted_domain xs))"
    by (rule sum.distinct_set_conv_list, rule distinct_sorted_wrt_irrefl,
        fact, fact transp_less, fact sorted_OAlist_tc_sorted_domain)
  also have "... = sum_list (map snd (list_of_oalist_tc xs))"
    by (rule arg_cong[where f=sum_list], simp add: OAlist_tc_sorted_domain_def OAlist_tc_lookup_eq_valueI)
  finally show ?thesis .
qed

lemma single_PP_oalist [code]: "single_pp x e = PP_oalist (oalist_tc_of_list [(x, e)])"
  by (rule pp_eqI, simp add: lookup_single_pp OAlist_tc_lookup_single)

definition adds_pp_add_linorder :: "('b, 'a::add_linorder) pp  _  bool"
  where [code_abbrev]: "adds_pp_add_linorder = (adds)"

lemma adds_pp_PP_oalist [code]:
  "adds_pp_add_linorder (PP_oalist xs) (PP_oalist ys) = OAlist_tc_prod_ord (λ_. less_eq) xs ys"
  for xs ys::"('a::linorder, 'b::add_linorder_min) oalist_tc"
proof (simp add: adds_pp_add_linorder_def adds_pp_iff adds_poly_mapping lookup_pp.rep_eq[symmetric] OAlist_tc_prod_ord_alt le_fun_def,
      intro iffI allI ballI)
  fix k
  assume "x. OAlist_tc_lookup xs x  OAlist_tc_lookup ys x"
  thus "OAlist_tc_lookup xs k  OAlist_tc_lookup ys k" by blast
next
  fix x
  assume *: "kfst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys).
              OAlist_tc_lookup xs k  OAlist_tc_lookup ys k"
  show "OAlist_tc_lookup xs x  OAlist_tc_lookup ys x"
  proof (cases "x  fst ` set (list_of_oalist_tc xs)  fst ` set (list_of_oalist_tc ys)")
    case True
    with * show ?thesis ..
  next
    case False
    hence "x  set (OAlist_tc_sorted_domain xs)" and "x  set (OAlist_tc_sorted_domain ys)"
      by (simp_all add: set_OAlist_tc_sorted_domain)
    thus ?thesis by (simp add: in_OAlist_tc_sorted_domain_iff_lookup)
  qed
qed

subsubsection ‹Constructor›

definition "sparse0 xs = PP_oalist (oalist_tc_of_list xs)" ―‹sparse representation›

subsubsection ‹Computations›

experiment begin

abbreviation "X  0::nat"
abbreviation "Y  1::nat"
abbreviation "Z  2::nat"

value [code] "sparse0 [(X, 2::nat), (Z, 7)]"

lemma
  "sparse0 [(X, 2::nat), (Z, 7)] - sparse0 [(X, 2), (Z, 2)] = sparse0 [(Z, 5)]"
  by eval

lemma
  "lcs (sparse0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse0 [(Y, 3), (Z, 2)]) = sparse0 [(X, 2), (Y, 3), (Z, 7)]"
  by eval

lemma
  "(sparse0 [(X, 2::nat), (Z, 1)]) adds (sparse0 [(X, 3), (Y, 2), (Z, 1)])"
  by eval

lemma
  "lookup_pp (sparse0 [(X, 2::nat), (Z, 3)]) X = 2"
  by eval

lemma
  "deg_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
  by eval

lemma
  "lex_comp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)]) = Lt"
  by eval

lemma
  "lex_comp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)], 3::nat) (sparse0 [(X, 4)], 2) = Lt"
  by eval

lemma
  "lex_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)])"
  by eval

lemma
  "lex_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)])"
  by eval

lemma
  "¬ dlex_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse0 [(X, 4)])"
  by eval

lemma
  "dlex_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse0 [(X, 5)])"
  by eval

lemma
  "¬ drlex_pp (sparse0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse0 [(X, 5)])"
  by eval

end

subsection MP_oalist›

lift_definition MP_oalist :: "('a::nat_term, 'b::zero) oalist_ntm  'a 0 'b"
  is OAlist_lookup_ntm
proof -
  fix xs :: "('a, 'b) oalist_ntm"
  have "{x. OAlist_lookup_ntm xs x  0}  fst ` set (fst (list_of_oalist_ntm xs))"
  proof (rule, simp)
    fix x
    assume "OAlist_lookup_ntm xs x  0"
    thus "x  fst ` set (fst (list_of_oalist_ntm xs))"
      using oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain by blast
  qed
  also have "finite ..." by simp
  finally (finite_subset) show "finite {x. OAlist_lookup_ntm xs x  0}" .
qed

lemmas [simp, code] = MP_oalist.rep_eq

code_datatype MP_oalist

lemma keys_MP_oalist [code]: "keys (MP_oalist xs) = set (map fst (fst (list_of_oalist_ntm xs)))"
  by (rule set_eqI, simp add: in_keys_iff oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])

lemma MP_oalist_empty [simp]: "MP_oalist (OAlist_empty_ntm ko) = 0"
  by (rule poly_mapping_eqI, simp add: oa_ntm.lookup_empty)

lemma zero_MP_oalist [code]: "(0::('a::{linorder,nat_term} 0 'b::zero)) = MP_oalist (OAlist_empty_ntm nat_term_order_of_le)"
  by simp

definition is_zero :: "('a 0 'b::zero)  bool"
  where [code_abbrev]: "is_zero p  (p = 0)"

lemma is_zero_MP_oalist [code]: "is_zero (MP_oalist xs) = List.null (fst (list_of_oalist_ntm xs))"
  unfolding is_zero_def List.null_def
proof
  assume "MP_oalist xs = 0"
  hence "OAlist_lookup_ntm xs k = 0" for k by (simp add: poly_mapping_eq_iff)
  thus "fst (list_of_oalist_ntm xs) = []"
    by (metis image_eqI ko_ntm.min_key_val_raw_in oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain)
next
  assume "fst (list_of_oalist_ntm xs) = []"
  hence "OAlist_lookup_ntm xs k = 0" for k
    by (metis oa_ntm.list_of_oalist_empty oa_ntm.lookup_empty oalist_ntm_eqI surjective_pairing)
  thus "MP_oalist xs = 0" by (simp add: poly_mapping_eq_iff ext)
qed

lemma plus_MP_oalist [code]: "MP_oalist xs + MP_oalist ys = MP_oalist (OAlist_map2_val_neutr_ntm (λ_. (+)) xs ys)"
  by (rule poly_mapping_eqI, simp add: lookup_plus_fun, rule oa_ntm.lookup_map2_val_neutr[symmetric], simp_all)

lemma minus_MP_oalist [code]: "MP_oalist xs - MP_oalist ys = MP_oalist (OAlist_map2_val_rneutr_ntm (λ_. (-)) xs ys)"
  by (rule poly_mapping_eqI, simp add: lookup_minus_fun, rule oa_ntm.lookup_map2_val_rneutr[symmetric], simp)

lemma uminus_MP_oalist [code]: "- MP_oalist xs = MP_oalist (OAlist_map_val_ntm (λ_. uminus) xs)"
  by (rule poly_mapping_eqI, simp, rule oa_ntm.lookup_map_val[symmetric], simp)

lemma equal_MP_oalist [code]: "equal_class.equal (MP_oalist xs) (MP_oalist ys) = (OAlist_eq_ntm xs ys)"
  by (simp add: oa_ntm.oalist_eq_alt equal_eq poly_mapping_eq_iff)

lemma map_MP_oalist [code]: "Poly_Mapping.map f (MP_oalist xs) = MP_oalist (OAlist_map_val_ntm (λ_. f) xs)"
proof -
  have eq: "OAlist_map_val_ntm (λ_. f) xs = OAlist_map_val_ntm (λ_ c. f c when c  0) xs"
  proof (rule oa_ntm.map_val_cong)
    fix t c
    assume *: "(t, c)  set (fst (list_of_oalist_ntm xs))"
    hence "fst (t, c)  fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
    hence "OAlist_lookup_ntm xs t  0"
      by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
    moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
    ultimately have "c  0" by simp
    thus "f c = (f c when c  0)" by simp
  qed
  show ?thesis
    by (rule poly_mapping_eqI, simp add: Poly_Mapping.map.rep_eq eq, rule oa_ntm.lookup_map_val[symmetric], simp)
qed

lemma range_MP_oalist [code]: "Poly_Mapping.range (MP_oalist xs) = set (map snd (fst (list_of_oalist_ntm xs)))"
proof (simp add: Poly_Mapping.range.rep_eq, intro set_eqI iffI)
  fix c
  assume "c  range (OAlist_lookup_ntm xs) - {0}"
  hence "c  range (OAlist_lookup_ntm xs)" and "c  0" by simp_all
  from this(1) obtain t where "OAlist_lookup_ntm xs t = c" by fastforce
  with c  0 have "(t, c)  set (fst (list_of_oalist_ntm xs))" by (simp add: oa_ntm.lookup_eq_value)
  hence "snd (t, c)  snd ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
  thus "c  snd ` set (fst (list_of_oalist_ntm xs))" by simp
next
  fix c
  assume "c  snd ` set (fst (list_of_oalist_ntm xs))"
  then obtain t where *: "(t, c)  set (fst (list_of_oalist_ntm xs))" by fastforce
  hence "fst (t, c)  fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
  hence "OAlist_lookup_ntm xs t  0"
    by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
  moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
  ultimately show "c  range (OAlist_lookup_ntm xs) - {0}" by fastforce
qed

lemma if_poly_mapping_eq_iff:
  "(if x = y then a else b) = (if (ikeys x  keys y. lookup x i = lookup y i) then a else b)"
  by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)

lemma keys_add_eq: "keys (a + b) = keys a  keys b - {x  keys a  keys b. lookup a x + lookup b x = 0}"
  by (auto simp: in_keys_iff lookup_add add_eq_0_iff
      simp del: lookup_not_eq_zero_eq_in_keys)

locale gd_nat_term =
    gd_term pair_of_term term_of_pair
        "λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
        "λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
        "le_of_nat_term_order cmp_term"
        "lt_of_nat_term_order cmp_term"
      for pair_of_term::"'t::nat_term  ('a::{nat_term,graded_dickson_powerprod} × 'k::{countable,the_min,wellorder})"
      and term_of_pair::"('a × 'k)  't"
      and cmp_term +
    assumes splus_eq_splus: "t  u = nat_term_class.splus (term_of_pair (t, the_min)) u"
begin

definition shift_map_keys :: "'a  ('b  'b)  ('t, 'b) oalist_ntm  ('t, 'b::semiring_0) oalist_ntm"
  where "shift_map_keys t f xs = OAlist_ntm (map_raw (λkv. (t  fst kv, f (snd kv))) (list_of_oalist_ntm xs))"

lemma list_of_oalist_shift_keys:
  "list_of_oalist_ntm (shift_map_keys t f xs) = (map_raw (λkv. (t  fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
  unfolding shift_map_keys_def
  by (rule oa_ntm.list_of_oalist_of_list_id, rule ko_ntm.oalist_inv_map_raw, fact oalist_inv_list_of_oalist_ntm,
      simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)

lemma lookup_shift_map_keys_plus:
  "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) (t  u) = c * lookup (MP_oalist xs) u" (is "?l = ?r")
proof -
  let ?f = "λkv. (t  fst kv, c * snd kv)"
  have "?l = lookup_ko_ntm (map_raw ?f (list_of_oalist_ntm xs)) (fst (?f (u, c)))"
    by (simp add: oa_ntm.lookup_def list_of_oalist_shift_keys)
  also have "... = snd (?f (u, lookup_ko_ntm (list_of_oalist_ntm xs) u))"
    by (rule ko_ntm.lookup_raw_map_raw, fact oalist_inv_list_of_oalist_ntm, simp,
        simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
  also have "... = ?r" by (simp add: oa_ntm.lookup_def)
  finally show ?thesis .
qed

lemma keys_shift_map_keys_subset:
  "keys (MP_oalist (shift_map_keys t ((*) c) xs))  ((⊕) t) ` keys (MP_oalist xs)" (is "?l  ?r")
proof -
  let ?f = "λkv. (t  fst kv, c * snd kv)"
  have "?l = fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))"
    by (simp add: keys_MP_oalist list_of_oalist_shift_keys)
  also from ko_ntm.map_raw_subset have "...  fst ` ?f ` set (fst (list_of_oalist_ntm xs))"
    by (rule image_mono)
  also have "...  ?r" by (simp add: keys_MP_oalist image_image)
  finally show ?thesis .
qed

lemma monom_mult_MP_oalist [code]:
  "monom_mult c t (MP_oalist xs) =
    MP_oalist (if c = 0 then OAlist_empty_ntm (snd (list_of_oalist_ntm xs)) else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
  case True
  hence "monom_mult c t (MP_oalist xs) = 0" using monom_mult_zero_left by simp
  thus ?thesis using True by simp
next
  case False
  have "monom_mult c t (MP_oalist xs) = MP_oalist (shift_map_keys t ((*) c) xs)"
  proof (rule poly_mapping_eqI, simp add: lookup_monom_mult del: MP_oalist.rep_eq, intro conjI impI)
    fix u
    assume "t addsp u"
    then obtain v where "u = t  v" by (rule adds_ppE)
    thus "c * lookup (MP_oalist xs) (u  t) = lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u"
      by (simp add: splus_sminus lookup_shift_map_keys_plus del: MP_oalist.rep_eq)
  next
    fix u
    assume "¬ t addsp u"
    have "u  keys (MP_oalist (shift_map_keys t ((*) c) xs))"
    proof
      assume "u  keys (MP_oalist (shift_map_keys t ((*) c) xs))"
      also have "...  ((⊕) t) ` keys (MP_oalist xs)" by (fact keys_shift_map_keys_subset)
      finally obtain v where "u = t  v" ..
      hence "t addsp u" by (rule adds_ppI)
      with ¬ t addsp u show False ..
    qed
    thus "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u = 0" by (simp add: in_keys_iff)
  qed
  thus ?thesis by (simp add: False)
qed

lemma mult_scalar_MP_oalist [code]:
  "(MP_oalist xs)  (MP_oalist ys) =
      (if is_zero (MP_oalist xs) then
        MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))
      else
        let ct = OAlist_hd_ntm xs in
        monom_mult (snd ct) (fst ct) (MP_oalist ys) + (MP_oalist (OAlist_tl_ntm xs))  (MP_oalist ys))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "MP_oalist xs  MP_oalist ys = MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))"
    by (simp add: is_zero_def)
next
  assume "¬ is_zero (MP_oalist xs)"
  hence *: "fst (list_of_oalist_ntm xs)  []" by (simp add: is_zero_MP_oalist List.null_def)
  define ct where "ct = OAlist_hd_ntm xs"
  have eq: "except (MP_oalist xs) {fst ct} = MP_oalist (OAlist_tl_ntm xs)"
    by (rule poly_mapping_eqI, simp add: lookup_except ct_def oa_ntm.lookup_tl')
  have "MP_oalist xs  MP_oalist ys =
          monom_mult (lookup (MP_oalist xs) (fst ct)) (fst ct) (MP_oalist ys) +
          except (MP_oalist xs) {fst ct}  MP_oalist ys" by (fact mult_scalar_rec_left)
  also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + except (MP_oalist xs) {fst ct}  MP_oalist ys"
    using * by (simp add: ct_def oa_ntm.snd_hd)
  also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs)  MP_oalist ys"
    by (simp only: eq)
  finally show "MP_oalist xs  MP_oalist ys =
                (let ct = OAlist_hd_ntm xs in
                  monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs)  MP_oalist ys)"
    by (simp add: ct_def Let_def)
qed

end (* ordered_nat_term *)

subsubsection ‹Special case of addition: adding monomials›

definition plus_monomial_less :: "('a 0 'b)  'b  'a  ('a 0 'b::monoid_add)"
  where "plus_monomial_less p c u = p + monomial c u"

text @{const plus_monomial_less} is useful when adding a monomial to a polynomial, where the term
  of the monomial is known to be smaller than all terms in the polynomial, because it can be
  implemented more efficiently than general addition.›

lemma plus_monomial_less_MP_oalist [code]:
  "plus_monomial_less (MP_oalist xs) c u = MP_oalist (OAlist_update_by_fun_gr_ntm u (λc0. c0 + c) xs)"
  unfolding plus_monomial_less_def oa_ntm.update_by_fun_gr_eq_update_by_fun
  by (rule poly_mapping_eqI, simp add: lookup_plus_fun oa_ntm.lookup_update_by_fun lookup_single)

text @{const plus_monomial_less} is computed by @{const OAlist_update_by_fun_gr_ntm}, because greater
  terms come @{emph ‹before›} smaller ones in @{type oalist_ntm}.›

subsubsection ‹Constructors›

definition "distr0 ko xs = MP_oalist (oalist_of_list_ntm (xs, ko))" ―‹sparse representation›

definition V0 :: "'a  ('a, nat) pp 0 'b::{one,zero}" where
  "V0 n  monomial 1 (single_pp n 1)"

definition C0 :: "'b  ('a, nat) pp 0 'b::zero" where "C0 c  monomial c 0"

lemma C0_one: "C0 1 = 1"
  by (simp add: C0_def)

lemma C0_numeral: "C0 (numeral x) = numeral x"
  by (auto intro!: poly_mapping_eqI simp: C0_def lookup_numeral)

lemma C0_minus: "C0 (- x) = - C0 x"
  by (simp add: C0_def single_uminus)

lemma C0_zero: "C0 0 = 0"
  by (auto intro!: poly_mapping_eqI simp: C0_def)

lemma V0_power: "V0 v ^ n = monomial 1 (single_pp v n)"
  by (induction n) (auto simp: V0_def mult_single single_pp_plus)

lemma single_MP_oalist [code]: "Poly_Mapping.single k v = distr0 nat_term_order_of_le [(k, v)]"
  unfolding distr0_def by (rule poly_mapping_eqI, simp add: lookup_single OAlist_lookup_ntm_single)

lemma one_MP_oalist [code]: "1 = distr0 nat_term_order_of_le [(0, 1)]"
  by (metis single_MP_oalist single_one)

lemma except_MP_oalist [code]: "except (MP_oalist xs) S = MP_oalist (OAlist_filter_ntm (λkv. fst kv  S) xs)"
  by (rule poly_mapping_eqI, simp add: lookup_except oa_ntm.lookup_filter)

subsubsection ‹Changing the Internal Order›

definition change_ord :: "'a::nat_term_compare nat_term_order  ('a 0 'b)  ('a 0 'b)"
  where "change_ord to = (λx. x)"

lemma change_ord_MP_oalist [code]: "change_ord to (MP_oalist xs) = MP_oalist (OAlist_reorder_ntm to xs)"
  by (rule poly_mapping_eqI, simp add: change_ord_def oa_ntm.lookup_reorder)

subsubsection ‹Ordered Power-Products›

lemma foldl_assoc:
  assumes "x y z. f (f x y) z = f x (f y z)"
  shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
  fix a b
  show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
  fix a b x xs
  assume "a b. foldl f (f a b) xs = f a (foldl f b xs)"
  from assms[of a b x] this[of a "f b x"]
    show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
  qed

context gd_nat_term
begin

definition ord_pp :: "'a  'a  bool"
  where "ord_pp s t = le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"

definition ord_pp_strict :: "'a  'a  bool"
  where "ord_pp_strict s t = lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"

lemma lt_MP_oalist [code]:
  "lt (MP_oalist xs) = (if is_zero (MP_oalist xs) then min_term else fst (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "lt (MP_oalist xs) = min_term" by (simp add: is_zero_def)
next
  assume "¬ is_zero (MP_oalist xs)"
  hence "fst (list_of_oalist_ntm xs)  []" by (simp add: is_zero_MP_oalist List.null_def)
  show "lt (MP_oalist xs) = fst (OAlist_min_key_val_ntm cmp_term xs)"
  proof (rule lt_eqI_keys)
    show "fst (OAlist_min_key_val_ntm cmp_term xs)  keys (MP_oalist xs)"
      by (simp add: keys_MP_oalist, rule imageI, rule oa_ntm.min_key_val_in, fact)
  next
    fix u
    assume "u  keys (MP_oalist xs)"
    also have "... = fst ` set (fst (list_of_oalist_ntm xs))" by (simp add: keys_MP_oalist)
    finally obtain z where "z  set (fst (list_of_oalist_ntm xs))" and "u = fst z" ..
    from this(1) have "ko.le (key_order_of_nat_term_order_inv cmp_term) (fst (OAlist_min_key_val_ntm cmp_term xs)) u"
      unfolding u = fst z by (rule oa_ntm.min_key_val_minimal)
    thus "le_of_nat_term_order cmp_term u (fst (OAlist_min_key_val_ntm cmp_term xs))"
      by (simp add: le_of_nat_term_order_alt)
  qed
qed

lemma lc_MP_oalist [code]:
  "lc (MP_oalist xs) = (if is_zero (MP_oalist xs) then 0 else snd (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "lc (MP_oalist xs) = 0" by (simp add: is_zero_def)
next
  assume "¬ is_zero (MP_oalist xs)"
  moreover from this have "fst (list_of_oalist_ntm xs)  []" by (simp add: is_zero_MP_oalist List.null_def)
  ultimately show "lc (MP_oalist xs) = snd (OAlist_min_key_val_ntm cmp_term xs)"
    by (simp add: lc_def lt_MP_oalist oa_ntm.snd_min_key_val)
qed

lemma tail_MP_oalist [code]: "tail (MP_oalist xs) = MP_oalist (OAlist_except_min_ntm cmp_term xs)"
proof (cases "is_zero (MP_oalist xs)")
  case True
  hence "fst (list_of_oalist_ntm xs) = []" by (simp add: is_zero_MP_oalist List.null_def)
  hence "fst (list_of_oalist_ntm (OAlist_except_min_ntm cmp_term xs)) = []"
    by (rule oa_ntm.except_min_Nil)
  hence "is_zero (MP_oalist (OAlist_except_min_ntm cmp_term xs))"
    by (simp add: is_zero_MP_oalist List.null_def)
  with True show ?thesis by (simp add: is_zero_def)
next
  case False
  show ?thesis by (rule poly_mapping_eqI, simp add: lookup_tail_2 oa_ntm.lookup_except_min' lt_MP_oalist False)
qed

definition comp_opt_p :: "('t 0 'c::zero, 't 0 'c) comp_opt"
  where "comp_opt_p p q =
              (if p = q then Some Eq else if ord_strict_p p q then Some Lt else if ord_strict_p q p then Some Gt else None)"

lemma comp_opt_p_MP_oalist [code]:
  "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
    OAlist_lex_ord_ntm cmp_term (λ_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None) xs ys"
proof -
  let ?f = "λ_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None"
  show ?thesis
  proof (cases "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Eq")
    case True
    hence "MP_oalist xs = MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
    hence "lookup (MP_oalist xs) = lookup (MP_oalist ys)" by (rule arg_cong)
    hence eq: "OAlist_lookup_ntm xs = OAlist_lookup_ntm ys" by simp
    have "OAlist_lex_ord_ntm cmp_term ?f xs ys = Some Eq"
      by (rule oa_ntm.lex_ord_EqI, simp add: eq)
    with True show ?thesis by simp
  next
    case False
    hence neq: "MP_oalist xs  MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
    then obtain v where 1: "v  keys (MP_oalist xs)  keys (MP_oalist ys)"
      and 2: "lookup (MP_oalist xs) v  lookup (MP_oalist ys) v"
      and 3: "u. lt_of_nat_term_order cmp_term v u  lookup (MP_oalist xs) u = lookup (MP_oalist ys) u"
      by (rule poly_mapping_neqE, blast)
    show ?thesis
    proof (rule HOL.sym, rule oa_ntm.lex_ord_valI)
      from 1 show "v  fst ` set (fst (list_of_oalist_ntm xs))  fst ` set (fst (list_of_oalist_ntm ys))"
        by (simp add: keys_MP_oalist)
    next
      from 2 have 4: "OAlist_lookup_ntm xs v  OAlist_lookup_ntm ys v" by simp
      show "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
            (if OAlist_lookup_ntm xs v = OAlist_lookup_ntm ys v then Some Eq
             else if OAlist_lookup_ntm xs v = 0 then Some Lt
             else if OAlist_lookup_ntm ys v = 0 then Some Gt else None)"
      proof (simp add: 4, intro conjI impI)
        assume "OAlist_lookup_ntm ys v = 0" and "OAlist_lookup_ntm xs v = 0"
        with 4 show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by simp
      next
        assume "OAlist_lookup_ntm xs v  0" and "OAlist_lookup_ntm ys v = 0"
        hence "lookup (MP_oalist ys) v = 0" and "lookup (MP_oalist xs) v  0" by simp_all
        hence "ord_strict_p (MP_oalist ys) (MP_oalist xs)" using 3[symmetric]
          by (rule ord_strict_pI)
        with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Gt" by (auto simp: comp_opt_p_def)
      next
        assume "OAlist_lookup_ntm ys v  0" and "OAlist_lookup_ntm xs v = 0"
        hence "lookup (MP_oalist xs) v = 0" and "lookup (MP_oalist ys) v  0" by simp_all
        hence "ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule ord_strict_pI)
        with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by (auto simp: comp_opt_p_def)
      next
        assume "OAlist_lookup_ntm xs v  0"
        hence "lookup (MP_oalist xs) v  0" by simp
        with 2 have a: "¬ ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule not_ord_strict_pI)
        assume "OAlist_lookup_ntm ys v  0"
        hence "lookup (MP_oalist ys) v  0" by simp
        with 2[symmetric] have "¬ ord_strict_p (MP_oalist ys) (MP_oalist xs)"
          using 3[symmetric] by (rule not_ord_strict_pI)
        with neq a show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = None" by (auto simp: comp_opt_p_def)
      qed
    next
      fix u
      assume "ko.lt (key_order_of_nat_term_order_inv cmp_term) u v"
      hence "lt_of_nat_term_order cmp_term v u" by (simp only: lt_of_nat_term_order_alt)
      hence "lookup (MP_oalist xs) u = lookup (MP_oalist ys) u" by (rule 3)
      thus "(if OAlist_lookup_ntm xs u = OAlist_lookup_ntm ys u then Some Eq
            else if OAlist_lookup_ntm xs u = 0 then Some Lt
            else if OAlist_lookup_ntm ys u = 0 then Some Gt else None) = Some Eq" by simp
    qed fact
  qed
qed

lemma compute_ord_p [code]: "ord_p p q = (let aux = comp_opt_p p q in aux = Some Lt  aux = Some Eq)"
  by (auto simp: ord_p_def comp_opt_p_def)

lemma compute_ord_p_strict [code]: "ord_strict_p p q = (comp_opt_p p q = Some Lt)"
  by (auto simp: comp_opt_p_def)

lemma keys_to_list_MP_oalist [code]: "keys_to_list (MP_oalist xs) = OAlist_sorted_domain_ntm cmp_term xs"
proof -
  have eq: "ko.lt (key_order_of_nat_term_order_inv cmp_term) = ord_term_strict_conv"
    by (intro ext, simp add: lt_of_nat_term_order_alt)
  have 1: "irreflp ord_term_strict_conv" by (rule irreflpI, simp)
  have 2: "transp ord_term_strict_conv" by (rule transpI, simp)
  have "antisymp ord_term_strict_conv" by (rule antisympI, simp)
  moreover have 3: "sorted_wrt ord_term_strict_conv (keys_to_list (MP_oalist xs))"
    unfolding keys_to_list_def by (fact pps_to_list_sorted_wrt)
  moreover note _
  moreover have 4: "sorted_wrt ord_term_strict_conv (OAlist_sorted_domain_ntm cmp_term xs)"
    unfolding eq[symmetric] by (fact oa_ntm.sorted_sorted_domain)
  ultimately show ?thesis
  proof (rule sorted_wrt_distinct_set_unique)
    from 1 2 3 show "distinct (keys_to_list (MP_oalist xs))" by (rule distinct_sorted_wrt_irrefl)
  next
    from 1 2 4 show "distinct (OAlist_sorted_domain_ntm cmp_term xs)" by (rule distinct_sorted_wrt_irrefl)
  next
    show "set (keys_to_list (MP_oalist xs)) = set (OAlist_sorted_domain_ntm cmp_term xs)"
      by (simp add: set_keys_to_list keys_MP_oalist oa_ntm.set_sorted_domain)
  qed
qed

end (* ordered_nat_term *)

lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting

subsection ‹Interpretations›

lemma term_powerprod_gd_term:
  fixes pair_of_term :: "'t::nat_term  ('a::{graded_dickson_powerprod,nat_pp_compare} × 'k::{the_min,wellorder})"
  assumes "term_powerprod pair_of_term term_of_pair"
    and "v. fst (rep_nat_term v) = rep_nat_pp (fst (pair_of_term v))"
    and "t. snd (rep_nat_term (term_of_pair (t, the_min))) = 0"
    and "v w. snd (pair_of_term v)  snd (pair_of_term w)  snd (rep_nat_term v)  snd (rep_nat_term w)"
    and "s t k. term_of_pair (s + t, k) = splus (term_of_pair (s, k)) (term_of_pair (t, k))"
    and "t v. term_powerprod.splus pair_of_term term_of_pair t v = splus (term_of_pair (t, the_min)) v"
  shows "gd_term pair_of_term term_of_pair
        (λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
        (λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
proof -
  from assms(1) interpret tp: term_powerprod pair_of_term term_of_pair .
  let ?f = "λx. term_of_pair (x, the_min)"
  show ?thesis
  proof (intro gd_term.intro ordered_term.intro)
    from assms(1) show "term_powerprod pair_of_term term_of_pair" .
  next
    show "ordered_powerprod (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
                        (λs t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
    proof (intro ordered_powerprod.intro ordered_powerprod_axioms.intro)
      show "class.linorder (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
                        (λs t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
      proof (unfold_locales, simp_all add: lt_of_nat_term_order_alt le_of_nat_term_order_alt ko.linear ko.less_le_not_le)
        fix x y
        assume "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (x, the_min)) (term_of_pair (y, the_min))"
          and "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (y, the_min)) (term_of_pair (x, the_min))"
        hence "term_of_pair (x, the_min) = term_of_pair (y, the_min)"
          by (rule ko.antisym)
        hence "(x, the_min) = (y, the_min::'k)" by (rule tp.term_of_pair_injective)
        thus "x = y" by simp
      qed
    next
      fix t
      show "le_of_nat_term_order cmp_term (?f 0) (?f t)"
        unfolding le_of_nat_term_order
        by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare,
            simp add: assms(3), simp add: assms(2) zero_pp tp.pair_term)
    next
      fix s t u
      assume "le_of_nat_term_order cmp_term (?f s) (?f t)"
      hence "le_of_nat_term_order cmp_term (?f (u + s)) (?f (u + t))"
        by (simp add: le_of_nat_term_order assms(5) nat_term_compare_splus)
      thus "le_of_nat_term_order cmp_term (?f (s + u)) (?f (t + u))" by (simp only: ac_simps)
    qed
  next
    show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
      by (fact linorder_le_of_nat_term_order)
  next
    show "ordered_term_axioms pair_of_term term_of_pair (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
       (le_of_nat_term_order cmp_term)"
    proof
      fix v w t
      assume "le_of_nat_term_order cmp_term v w"
      thus "le_of_nat_term_order cmp_term (t  v) (t  w)"
        by (simp add: le_of_nat_term_order assms(6) nat_term_compare_splus)
    next
      fix v w
      assume "le_of_nat_term_order cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w))"
      hence 3: "nat_term_compare cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w))  Gt"
        by (simp add: le_of_nat_term_order)
      assume "tp.component_of_term v  tp.component_of_term w"
      hence 4: "snd (rep_nat_term v)  snd (rep_nat_term w)"
        by (simp add: tp.component_of_term_def assms(4))
      note comparator_nat_term_compare nat_term_comp_nat_term_compare
      moreover have "fst (rep_nat_term v) = fst (rep_nat_term (?f (tp.pp_of_term v)))"
        by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
      moreover have "fst (rep_nat_term w) = fst (rep_nat_term (?f (tp.pp_of_term w)))"
        by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
      moreover note 4
      moreover have "snd (rep_nat_term (?f (tp.pp_of_term v))) = snd (rep_nat_term (?f (tp.pp_of_term w)))"
        by (simp add: assms(3))
      ultimately show "le_of_nat_term_order cmp_term v w" unfolding le_of_nat_term_order using 3
        by (rule nat_term_compD4'')
    qed
  qed
qed

lemma gd_term_to_pair_unit:
  "gd_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod}  _) fst
        (λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
        (λs t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
proof (intro gd_term.intro ordered_term.intro)
  show "term_powerprod to_pair_unit fst" by unfold_locales
next
  show "ordered_powerprod (λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
                      (λs t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))"
    unfolding fst_conv using linorder_le_of_nat_term_order
  proof (intro ordered_powerprod.intro)
    from le_of_nat_term_order_zero_min show "ordered_powerprod_axioms (le_of_nat_term_order cmp_term)"
    proof (unfold_locales)
      fix s t u
      assume "le_of_nat_term_order cmp_term s t"
      hence "le_of_nat_term_order cmp_term (u + s) (u + t)" by (rule le_of_nat_term_order_plus_monotone)
      thus "le_of_nat_term_order cmp_term (s + u) (t + u)" by (simp only: ac_simps)
    qed
  qed
next
  show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
    by (fact linorder_le_of_nat_term_order)
next
  show "ordered_term_axioms to_pair_unit fst (λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
     (le_of_nat_term_order cmp_term)" by (unfold_locales, auto intro: le_of_nat_term_order_plus_monotone)
qed

corollary gd_nat_term_to_pair_unit:
  "gd_nat_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod}  _) fst cmp_term"
  by (rule gd_nat_term.intro, fact gd_term_to_pair_unit, rule gd_nat_term_axioms.intro, simp add: splus_pp_term)

lemma gd_term_id:
  "gd_term (λx::('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} × 'b::{nat,the_min}). x) (λx. x)
        (λs t. le_of_nat_term_order cmp_term (s, the_min) (t, the_min))
        (λs t. lt_of_nat_term_order cmp_term (s, the_min) (t, the_min))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
  apply (rule term_powerprod_gd_term)
  subgoal by unfold_locales
  subgoal by (simp add: rep_nat_term_prod_def)
  subgoal by (simp add: rep_nat_term_prod_def the_min_eq_zero)
  subgoal by (simp add: rep_nat_term_prod_def ord_iff[symmetric])
  subgoal by (simp add: splus_prod_def pprod.splus_def)
  subgoal by (simp add: splus_prod_def)
  done

corollary gd_nat_term_id: "gd_nat_term (λx. x) (λx. x) cmp_term"
  for cmp_term :: "('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} × 'c::{nat,the_min}) nat_term_order"
  by (rule gd_nat_term.intro, fact gd_term_id, rule gd_nat_term_axioms.intro, simp add: splus_prod_def)

subsection ‹Computations›

type_synonym 'a mpoly_tc = "(nat, nat) pp 0 'a"

global_interpretation punit0: gd_nat_term "to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod}  _" fst cmp_term
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (λx. x)"
  and "punit.component_of_term = (λ_. ())"
  for cmp_term
  defines monom_mult_punit = punit.monom_mult
  and mult_scalar_punit = punit.mult_scalar
  and shift_map_keys_punit = punit0.shift_map_keys
  and ord_pp_punit = punit0.ord_pp
  and ord_pp_strict_punit = punit0.ord_pp_strict
  and min_term_punit = punit0.min_term
  and lt_punit = punit0.lt
  and lc_punit = punit0.lc
  and tail_punit = punit0.tail
  and comp_opt_p_punit = punit0.comp_opt_p
  and ord_p_punit = punit0.ord_p
  and ord_strict_p_punit = punit0.ord_strict_p
  and keys_to_list_punit = punit0.keys_to_list
  subgoal by (fact gd_nat_term_to_pair_unit)
  subgoal by (fact punit_adds_term)
  subgoal by (fact punit_pp_of_term)
  subgoal by (fact punit_component_of_term)
  done

lemma shift_map_keys_punit_MP_oalist [code abstract]:
  "list_of_oalist_ntm (shift_map_keys_punit t f xs) = map_raw (λ(k, v). (t + k, f v)) (list_of_oalist_ntm xs)"
  by (simp add: punit0.list_of_oalist_shift_keys case_prod_beta')

lemmas [code] = punit0.mult_scalar_MP_oalist[unfolded mult_scalar_punit_def punit_mult_scalar]
                punit0.punit_min_term

lemma ord_pp_punit_alt [code_unfold]: "ord_pp_punit = le_of_nat_term_order"
  by (intro ext, simp add: punit0.ord_pp_def)

lemma ord_pp_strict_punit_alt [code_unfold]: "ord_pp_strict_punit = lt_of_nat_term_order"
  by (intro ext, simp add: punit0.ord_pp_strict_def)

lemma gd_powerprod_ord_pp_punit: "gd_powerprod (ord_pp_punit cmp_term) (ord_pp_strict_punit cmp_term)"
  unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..

locale trivariate0_rat
begin

abbreviation X::"rat mpoly_tc" where "X  V0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y  V0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z  V0 (2::nat)"

end

experiment begin interpretation trivariate0_rat .

value [code] "X ^ 2"

value [code] "X2 * Z + 2 * Y ^ 3 * Z2"

value [code] "distr0 DRLEX [(sparse0 [(0::nat, 3::nat)], 1::rat)] = distr0 DRLEX [(sparse0 [(0, 3)], 1)]"

lemma
  "ord_strict_p_punit DRLEX (X2 * Z + 2 * Y ^ 3 * Z2) (X2 * Z2 + 2 * Y ^ 3 * Z2)"
  by eval

lemma
  "tail_punit DLEX (X2 * Z + 2 * Y ^ 3 * Z2) = X2 * Z"
  by eval

value [code] "min_term_punit::(nat, nat) pp"

value [code] "is_zero (distr0 DRLEX [(sparse0 [(0::nat, 3::nat)], 1::rat)])"

value [code] "lt_punit DRLEX (distr0 DRLEX [(sparse0 [(0::nat, 3::nat)], 1::rat)])"

lemma
  "lt_punit DRLEX (X2 * Z + 2 * Y ^ 3 * Z2) = sparse0 [(1, 3), (2, 2)]"
  by eval

lemma
  "lt_punit DRLEX (X + Y + Z) = sparse0 [(2, 1)]"
  by eval

lemma
  "keys (X2 * Z ^ 3 + 2 * Y ^ 3 * Z2) =
    {sparse0 [(0, 2), (2, 3)], sparse0 [(1, 3), (2, 2)]}"
  by eval

lemma
  "- 1 * X2 * Z ^ 7 + - 2 * Y ^ 3 * Z2 = - X2 * Z ^ 7 + - 2 * Y ^ 3 * Z2"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 + X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2 = X2 * Z ^ 7 + X2 * Z ^ 4"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 - X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2 =
    X2 * Z ^ 7 - X2 * Z ^ 4"
  by eval

lemma
  "lookup (X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 + 2) (sparse0 [(0, 2), (2, 7)]) = 1"
  by eval

lemma
  "X2 * Z ^ 7 + 2 * Y ^ 3 * Z2 
   X2 * Z ^ 4 + - 2 * Y ^ 3 * Z2"
  by eval

lemma
  "0 * X^2 * Z^7 + 0 * Y^3*Z2 = 0"
  by eval

lemma
  "monom_mult_punit 3 (sparse0 [(1, 2::nat)]) (X2 * Z + 2 * Y ^ 3 * Z2) =
    3 * Y2 * Z * X2 + 6 * Y ^ 5 * Z2"
  by eval

lemma
  "monomial (-4) (sparse0 [(0, 2::nat)]) = - 4 * X2"
  by eval

lemma "monomial (0::rat) (sparse0 [(0::nat, 2::nat)]) = 0"
  by eval

lemma
  "(X2 * Z + 2 * Y ^ 3 * Z2) * (X2 * Z ^ 3 + - 2 * Y ^ 3 * Z2) =
    X ^ 4 * Z ^ 4 + - 2 * X2 * Z ^ 3 * Y ^ 3 +
 - 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X2"
  by eval

end

subsection ‹Code setup for type MPoly›

text ‹postprocessing from Var0, Const0 to Var, Const›.›

lemmas [code_post] =
  plus_mpoly.abs_eq[symmetric]
  times_mpoly.abs_eq[symmetric]
  one_mpoly_def[symmetric]
  Var.abs_eq[symmetric]
  Const.abs_eq[symmetric]

instantiation mpoly::("{equal, zero}")equal begin

lift_definition equal_mpoly:: "'a mpoly  'a mpoly  bool" is HOL.equal .

instance proof standard qed (transfer, rule equal_eq)

end

end (* theory *)

Theory Quasi_PM_Power_Products

(* Author: Alexander Maletzky *)

section ‹Quasi-Poly-Mapping Power-Products›

theory Quasi_PM_Power_Products
  imports MPoly_Type_Class_Ordered
begin

text ‹In this theory we introduce a subclass of @{class graded_dickson_powerprod} that approximates
  polynomial mappings even closer. We need this class for signature-based Gr\"obner basis algorithms.›

definition (in monoid_add) hom_grading_fun :: "('a  nat)  (nat  'a  'a)  bool"
  where "hom_grading_fun d f  (n. (s t. f n (s + t) = f n s + f n t) 
          (t. d (f n t)  n  (d t  n  f n t = t)))"

definition (in monoid_add) hom_grading :: "('a  nat)  bool"
  where "hom_grading d  (f. hom_grading_fun d f)"

definition (in monoid_add) decr_grading :: "('a  nat)  nat  'a  'a"
  where "decr_grading d = (SOME f. hom_grading_fun d f)"

lemma decr_grading:
  assumes "hom_grading d"
  shows "hom_grading_fun d (decr_grading d)"
proof -
  from assms obtain f where "hom_grading_fun d f" unfolding hom_grading_def ..
  thus ?thesis unfolding decr_grading_def by (metis someI)
qed

lemma decr_grading_plus:
  "hom_grading d  decr_grading d n (s + t) = decr_grading d n s + decr_grading d n t"
  using decr_grading unfolding hom_grading_fun_def by blast

lemma decr_grading_zero:
  assumes "hom_grading d"
  shows "decr_grading d n 0 = (0::'a::cancel_comm_monoid_add)"
proof -
  have "decr_grading d n 0 = decr_grading d n (0 + 0)" by simp
  also from assms have "... = decr_grading d n 0 + decr_grading d n 0" by (rule decr_grading_plus)
  finally show ?thesis by simp
qed

lemma decr_grading_le: "hom_grading d  d (decr_grading d n t)  n"
  using decr_grading unfolding hom_grading_fun_def by blast

lemma decr_grading_idI: "hom_grading d  d t  n  decr_grading d n t = t"
  using decr_grading unfolding hom_grading_fun_def by blast

class quasi_pm_powerprod = ulcs_powerprod +
  assumes ex_hgrad: "d::'a  nat. dickson_grading d  hom_grading d"
begin

subclass graded_dickson_powerprod
proof
  from ex_hgrad show "d. dickson_grading d" by blast
qed

end (* quasi_pm_powerprod *)

lemma hom_grading_varnum:
  "hom_grading ((varnum X)::('x::countable 0 'b::add_wellorder)  nat)"
proof -
  define f where "f = (λn t. (except t (- (X  {x. elem_index x < n})))::'x 0 'b)"
  show ?thesis unfolding hom_grading_def hom_grading_fun_def
  proof (intro exI allI conjI impI)
    fix n s t
    show "f n (s + t) = f n s + f n t" by (simp only: f_def except_plus)
  next
    fix n t
    show "varnum X (f n t)  n" by (auto simp: varnum_le_iff keys_except f_def)
  next
    fix n t
    show "varnum X t  n  f n t = t" by (auto simp: f_def except_id_iff varnum_le_iff)
  qed
qed

instance poly_mapping :: (countable, add_wellorder) quasi_pm_powerprod
  by (standard, intro exI conjI, fact dickson_grading_varnum_empty, fact hom_grading_varnum)

context term_powerprod
begin

definition decr_grading_term :: "('a  nat)  nat  't  't"
  where "decr_grading_term d n v = term_of_pair (decr_grading d n (pp_of_term v), component_of_term v)"

definition decr_grading_p :: "('a  nat)  nat  ('t 0 'b)  ('t 0 'b::comm_monoid_add)"
  where "decr_grading_p d n p = (vkeys p. monomial (lookup p v) (decr_grading_term d n v))"

lemma decr_grading_term_splus:
  "hom_grading d  decr_grading_term d n (t  v) = decr_grading d n t  decr_grading_term d n v"
  by (simp add: decr_grading_term_def term_simps decr_grading_plus splus_def)

lemma decr_grading_term_le: "hom_grading d  d (pp_of_term (decr_grading_term d n v))  n"
  by (simp add: decr_grading_term_def term_simps decr_grading_le)

lemma decr_grading_term_idI: "hom_grading d  d (pp_of_term v)  n  decr_grading_term d n v = v"
  by (simp add: decr_grading_term_def term_simps decr_grading_idI)

lemma punit_decr_grading_term: "punit.decr_grading_term = decr_grading"
  by (intro ext, simp add: punit.decr_grading_term_def)

lemma decr_grading_p_zero: "decr_grading_p d n 0 = 0"
  by (simp add: decr_grading_p_def)

lemma decr_grading_p_monomial: "decr_grading_p d n (monomial c v) = monomial c (decr_grading_term d n v)"
  by (simp add: decr_grading_p_def)

lemma decr_grading_p_plus:
  "decr_grading_p d n (p + q) = (decr_grading_p d n p) + (decr_grading_p d n q)"
proof -
  from finite_keys finite_keys have fin: "finite (keys p  keys q)" by (rule finite_UnI)
  hence eq1: "(vkeys p  keys q. monomial (lookup p v) (decr_grading_term d n v)) =
              (vkeys p. monomial (lookup p v) (decr_grading_term d n v))"
  proof (rule sum.mono_neutral_right)
    show "vkeys p  keys q - keys p. monomial (lookup p v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed simp
  from fin have eq2: "(vkeys p  keys q. monomial (lookup q v) (decr_grading_term d n v)) =
              (vkeys q. monomial (lookup q v) (decr_grading_term d n v))"
  proof (rule sum.mono_neutral_right)
    show "vkeys p  keys q - keys q. monomial (lookup q v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed simp
  from fin Poly_Mapping.keys_add
  have "decr_grading_p d n (p + q) =
                (vkeys p  keys q. monomial (lookup (p + q) v) (decr_grading_term d n v))"
    unfolding decr_grading_p_def
  proof (rule sum.mono_neutral_left)
    show "vkeys p  keys q - keys (p + q). monomial (lookup (p + q) v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed
  also have "... = (vkeys p  keys q. monomial (lookup p v) (decr_grading_term d n v)) +
                   (vkeys p  keys q. monomial (lookup q v) (decr_grading_term d n v))"
    by (simp only: lookup_add single_add sum.distrib)
  also have "... = (decr_grading_p d n p) + (decr_grading_p d n q)"
    by (simp only: eq1 eq2 decr_grading_p_def)
  finally show ?thesis .
qed

corollary decr_grading_p_sum: "decr_grading_p d n (sum f A) = (aA. decr_grading_p d n (f a))"
  using decr_grading_p_zero decr_grading_p_plus by (rule fun_sum_commute)

lemma decr_grading_p_monom_mult:
  assumes "hom_grading d"
  shows "decr_grading_p d n (monom_mult c t p) = monom_mult c (decr_grading d n t) (decr_grading_p d n p)"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by (simp add: decr_grading_p_zero)
next
  case (2 p a s)
  from assms show ?case
    by (simp add: monom_mult_dist_right decr_grading_p_plus 2(3) monom_mult_monomial
        decr_grading_p_monomial decr_grading_term_splus)
qed

lemma decr_grading_p_mult_scalar:
  assumes "hom_grading d"
  shows "decr_grading_p d n (p  q) = punit.decr_grading_p d n p  decr_grading_p d n q"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by (simp add: punit.decr_grading_p_zero decr_grading_p_zero)
next
  case (2 p a s)
  from assms show ?case
    by (simp add: mult_scalar_distrib_right decr_grading_p_plus punit.decr_grading_p_plus 2(3)
        punit.decr_grading_p_monomial mult_scalar_monomial decr_grading_p_monom_mult punit_decr_grading_term)
qed

lemma decr_grading_p_keys_subset: "keys (decr_grading_p d n p)  decr_grading_term d n ` keys p"
proof
  fix v
  assume "v  keys (decr_grading_p d n p)"
  also have "...  (ukeys p. keys (monomial (lookup p u) (decr_grading_term d n u)))"
    unfolding decr_grading_p_def by (fact keys_sum_subset)
  finally obtain u where "u  keys p" and "v  keys (monomial (lookup p u) (decr_grading_term d n u))" ..
  from this(2) have eq: "v = decr_grading_term d n u" by (simp split: if_split_asm)
  show "v  decr_grading_term d n ` keys p" unfolding eq using u  keys p by (rule imageI)
qed

lemma decr_grading_p_idI':
  assumes "hom_grading d" and "v. v  keys p  d (pp_of_term v)  n"
  shows "decr_grading_p d n p = p"
proof -
  have "decr_grading_p d n p = (v  keys p. monomial (lookup p v) v)" unfolding decr_grading_p_def
    using refl
  proof (rule sum.cong)
    fix v
    assume "v  keys p"
    hence "d (pp_of_term v)  n" by (rule assms(2))
    with assms(1) have "decr_grading_term d n v = v" by (rule decr_grading_term_idI)
    thus "monomial (lookup p v) (decr_grading_term d n v) = monomial (lookup p v) v" by simp
  qed
  also have "... = p" by (fact poly_mapping_sum_monomials)
  finally show ?thesis .
qed

end (* term_powerprod *)

context gd_term
begin

lemma decr_grading_p_idI:
  assumes "hom_grading d" and "p  dgrad_p_set d m"
  shows "decr_grading_p d m p = p"
proof -
  from assms(2) have "v. v  keys p  d (pp_of_term v)  m"
    by (auto simp: dgrad_p_set_def dgrad_set_def)
  with assms(1) show ?thesis by (rule decr_grading_p_idI')
qed

lemma decr_grading_p_dgrad_p_setI:
  assumes "hom_grading d"
  shows "decr_grading_p d m p  dgrad_p_set d m"
proof (rule dgrad_p_setI)
  fix v
  assume "v  keys (decr_grading_p d m p)"
  hence "v  decr_grading_term d m ` keys p" using decr_grading_p_keys_subset ..
  then obtain u where "v = decr_grading_term d m u" ..
  with assms show "d (pp_of_term v)  m" by (simp add: decr_grading_term_le)
qed

lemma (in gd_term) in_pmdlE_dgrad_p_set:
  assumes "hom_grading d" and "B  dgrad_p_set d m" and "p  dgrad_p_set d m" and "p  pmdl B"
  obtains A q where "finite A" and "A  B" and "b. q b  punit.dgrad_p_set d m"
    and "p = (bA. q b  b)"
proof -
  from assms(4) obtain A q0 where "finite A" and "A  B" and p: "p = (bA. q0 b  b)"
    by (rule pmdl.spanE)
  define q where "q = (λb. punit.decr_grading_p d m (q0 b))"
  from ‹finite A A  B show ?thesis
  proof
    fix b
    show "q b  punit.dgrad_p_set d m" unfolding q_def using assms(1) by (rule punit.decr_grading_p_dgrad_p_setI)
  next
    from assms(1, 3) have "p = decr_grading_p d m p" by (simp only: decr_grading_p_idI)
    also from assms(1) have "... = (bA. q b  (decr_grading_p d m b))"
      by (simp add: p q_def decr_grading_p_sum decr_grading_p_mult_scalar)
    also from refl have "... = (bA. q b  b)"
    proof (rule sum.cong)
      fix b
      assume "b  A"
      hence "b  B" using A  B ..
      hence "b  dgrad_p_set d m" using assms(2) ..
      with assms(1) have "decr_grading_p d m b = b" by (rule decr_grading_p_idI)
      thus "q b  decr_grading_p d m b = q b  b" by simp
    qed
    finally show "p = (bA. q b  b)" .
  qed
qed

end (* gd_term *)

end (* theory *)

Theory MPoly_PM

(* Author: Alexander Maletzky *)

section ‹Multivariate Polynomials with Power-Products Represented by Polynomial Mappings›

theory MPoly_PM
  imports Quasi_PM_Power_Products
begin

text ‹Many notions introduced in this theory for type @{typ "('x 0 'a) 0 'b"} closely resemble
  those introduced in @{theory Polynomials.MPoly_Type} for type @{typ "'a mpoly"}.›

lemma monomial_single_power:
  "(monomial c (Poly_Mapping.single x k)) ^ n = monomial (c ^ n) (Poly_Mapping.single x (k * n))"
proof -
  have eq: "(i = 0..<n. Poly_Mapping.single x k) = Poly_Mapping.single x (k * n)"
    by (induct n, simp_all add: add.commute single_add)
  show ?thesis by (simp add: punit.monomial_power eq)
qed

lemma monomial_power_map_scale: "(monomial c t) ^ n = monomial (c ^ n) (n  t)"
proof -
  have "(i = 0..<n. t) = (i = 0..<n. 1)  t"
    by (simp only: map_scale_sum_distrib_right map_scale_one_left)
  thus ?thesis by (simp add: punit.monomial_power)
qed

lemma times_canc_left:
  assumes "h * p = h * q" and "h  (0::('x::linorder 0 nat) 0 'a::ring_no_zero_divisors)"
  shows "p = q"
proof (rule ccontr)
  assume "p  q"
  hence "p - q  0" by simp
  with assms(2) have "h * (p - q)  0" by simp
  hence "h * p  h * q" by (simp add: algebra_simps)
  thus False using assms(1) ..
qed

lemma times_canc_right:
  assumes "p * h = q * h" and "h  (0::('x::linorder 0 nat) 0 'a::ring_no_zero_divisors)"
  shows "p = q"
proof (rule ccontr)
  assume "p  q"
  hence "p - q  0" by simp
  hence "(p - q) * h  0" using assms(2) by simp
  hence "p * h  q * h" by (simp add: algebra_simps)
  thus False using assms(1) ..
qed

subsection ‹Degree›

lemma plus_minus_assoc_pm_nat_1: "s + t - u = (s - (u - t)) + (t - (u::_ 0 nat))"
  by (rule poly_mapping_eqI, simp add: lookup_add lookup_minus)

lemma plus_minus_assoc_pm_nat_2:
  "s + (t - u) = (s + (except (u - t) (- keys s))) + t - (u::_ 0 nat)"
proof (rule poly_mapping_eqI)
  fix x
  show "lookup (s + (t - u)) x = lookup (s + except (u - t) (- keys s) + t - u) x"
  proof (cases "x  keys s")
    case True
    thus ?thesis
      by (simp add: plus_minus_assoc_pm_nat_1 lookup_add lookup_minus lookup_except)
  next
    case False
    hence "lookup s x = 0" by (simp add: in_keys_iff)
    with False show ?thesis
      by (simp add: lookup_add lookup_minus lookup_except)
  qed
qed

lemma deg_pm_sum: "deg_pm (sum t A) = (aA. deg_pm (t a))"
  by (induct A rule: infinite_finite_induct) (auto simp: deg_pm_plus)

lemma deg_pm_mono: "s adds t  deg_pm s  deg_pm (t::_ 0 _::add_linorder_min)"
  by (metis addsE deg_pm_plus le_iff_add)

lemma adds_deg_pm_antisym: "s adds t  deg_pm t  deg_pm (s::_ 0 _::add_linorder_min)  s = t"
  by (metis (no_types, lifting) add.right_neutral add.right_neutral add_left_cancel addsE
      deg_pm_eq_0_iff deg_pm_mono deg_pm_plus dual_order.antisym)

lemma deg_pm_minus:
  assumes "s adds (t::_ 0 _::comm_monoid_add)"
  shows "deg_pm (t - s) = deg_pm t - deg_pm s"
proof -
  from assms have "(t - s) + s = t" by (rule adds_minus)
  hence "deg_pm t = deg_pm ((t - s) + s)" by simp
  also have " = deg_pm (t - s) + deg_pm s" by (simp only: deg_pm_plus)
  finally show ?thesis by simp
qed

lemma adds_group [simp]: "s adds (t::'a 0 'b::ab_group_add)"
proof (rule addsI)
  show "t = s + (t - s)" by simp
qed

lemmas deg_pm_minus_group = deg_pm_minus[OF adds_group]

lemma deg_pm_minus_le: "deg_pm (t - s)  deg_pm (t::_ 0 nat)"
proof -
  have "keys (t - s)  keys t" by (rule, simp add: lookup_minus in_keys_iff)
  hence "deg_pm (t - s) = (xkeys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
  also have "  (xkeys t. lookup t x)" by (rule sum_mono) (simp add: lookup_minus)
  also have " = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
  finally show ?thesis .
qed

lemma minus_id_iff: "t - s = t  keys t  keys (s::_ 0 nat) = {}"
proof
  assume "t - s = t"
  {
    fix x
    assume "x  keys t" and "x  keys s"
    hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
    hence "lookup (t - s) x  lookup t x" by (simp add: lookup_minus)
    with t - s = t have False by simp
  }
  thus "keys t  keys s = {}" by blast
next
  assume *: "keys t  keys s = {}"
  show "t - s = t"
  proof (rule poly_mapping_eqI)
    fix x
    have "lookup t x - lookup s x = lookup t x"
    proof (cases "x  keys t")
      case True
      with * have "x  keys s" by blast
      thus ?thesis by (simp add: in_keys_iff)
    next
      case False
      thus ?thesis by (simp add: in_keys_iff)
    qed
    thus "lookup (t - s) x = lookup t x" by (simp only: lookup_minus)
  qed
qed

lemma deg_pm_minus_id_iff: "deg_pm (t - s) = deg_pm t  keys t  keys (s::_ 0 nat) = {}"
proof
  assume eq: "deg_pm (t - s) = deg_pm t"
  {
    fix x
    assume "x  keys t" and "x  keys s"
    hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
    hence *: "lookup (t - s) x < lookup t x" by (simp add: lookup_minus)
    have "keys (t - s)  keys t" by (rule, simp add: lookup_minus in_keys_iff)
    hence "deg_pm (t - s) = (xkeys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
    also from finite_keys have " < (xkeys t. lookup t x)"
    proof (rule sum_strict_mono_ex1)
      show "xkeys t. lookup (t - s) x  lookup t x" by (simp add: lookup_minus)
    next
      from x  keys t * show "xkeys t. lookup (t - s) x < lookup t x" ..
    qed
    also have " = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
    finally have False by (simp add: eq)
  }
  thus "keys t  keys s = {}" by blast
next
  assume "keys t  keys s = {}"
  hence "t - s = t" by (simp only: minus_id_iff)
  thus "deg_pm (t - s) = deg_pm t" by (simp only:)
qed

definition poly_deg :: "(('x 0 'a::add_linorder) 0 'b::zero)  'a" where
  "poly_deg p = (if keys p = {} then 0 else Max (deg_pm ` keys p))"

definition maxdeg :: "(('x 0 'a::add_linorder) 0 'b::zero) set  'a" where
  "maxdeg A = Max (poly_deg ` A)"
  
definition mindeg :: "(('x 0 'a::add_linorder) 0 'b::zero) set  'a" where
  "mindeg A = Min (poly_deg ` A)"

lemma poly_deg_monomial: "poly_deg (monomial c t) = (if c = 0 then 0 else deg_pm t)"
  by (simp add: poly_deg_def)

lemma poly_deg_monomial_zero [simp]: "poly_deg (monomial c 0) = 0"
  by (simp add: poly_deg_monomial)

lemma poly_deg_zero [simp]: "poly_deg 0 = 0"
  by (simp only: single_zero[of 0, symmetric] poly_deg_monomial_zero)

lemma poly_deg_one [simp]: "poly_deg 1 = 0"
  by (simp only: single_one[symmetric] poly_deg_monomial_zero)

lemma poly_degE:
  assumes "p  0"
  obtains t where "t  keys p" and "poly_deg p = deg_pm t"
proof -
  from assms have "poly_deg p = Max (deg_pm ` keys p)" by (simp add: poly_deg_def)
  also have "  deg_pm ` keys p"
  proof (rule Max_in)
    from assms show "deg_pm ` keys p  {}" by simp
  qed simp
  finally obtain t where "t  keys p" and "poly_deg p = deg_pm t" ..
  thus ?thesis ..
qed

lemma poly_deg_max_keys: "t  keys p  deg_pm t  poly_deg p"
  using finite_keys by (auto simp: poly_deg_def)

lemma poly_deg_leI: "(t. t  keys p  deg_pm t  (d::'a::add_linorder_min))  poly_deg p  d"
  using finite_keys by (auto simp: poly_deg_def)

lemma poly_deg_lessI:
  "p  0  (t. t  keys p  deg_pm t < (d::'a::add_linorder_min))  poly_deg p < d"
  using finite_keys by (auto simp: poly_deg_def)

lemma poly_deg_zero_imp_monomial:
  assumes "poly_deg p = (0::'a::add_linorder_min)"
  shows "monomial (lookup p 0) 0 = p"
proof (rule keys_subset_singleton_imp_monomial, rule)
  fix t
  assume "t  keys p"
  have "t = 0"
  proof (rule ccontr)
    assume "t  0"
    hence "deg_pm t  0" by simp
    hence "0 < deg_pm t" using not_gr_zero by blast
    also from t  keys p have "...  poly_deg p" by (rule poly_deg_max_keys)
    finally have "poly_deg p  0" by simp
    from this assms show False ..
  qed
  thus "t  {0}" by simp
qed

lemma poly_deg_plus_le:
  "poly_deg (p + q)  max (poly_deg p) (poly_deg (q::(_ 0 'a::add_linorder_min) 0 _))"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (p + q)"
  also have "...  keys p  keys q" by (fact Poly_Mapping.keys_add)
  finally show "deg_pm t  max (poly_deg p) (poly_deg q)"
  proof
    assume "t  keys p"
    hence "deg_pm t  poly_deg p" by (rule poly_deg_max_keys)
    thus ?thesis by (simp add: le_max_iff_disj)
  next
    assume "t  keys q"
    hence "deg_pm t  poly_deg q" by (rule poly_deg_max_keys)
    thus ?thesis by (simp add: le_max_iff_disj)
  qed
qed

lemma poly_deg_uminus [simp]: "poly_deg (-p) = poly_deg p"
  by (simp add: poly_deg_def keys_uminus)

lemma poly_deg_minus_le:
  "poly_deg (p - q)  max (poly_deg p) (poly_deg (q::(_ 0 'a::add_linorder_min) 0 _))"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (p - q)"
  also have "...  keys p  keys q" by (fact keys_minus)
  finally show "deg_pm t  max (poly_deg p) (poly_deg q)"
  proof
    assume "t  keys p"
    hence "deg_pm t  poly_deg p" by (rule poly_deg_max_keys)
    thus ?thesis by (simp add: le_max_iff_disj)
  next
    assume "t  keys q"
    hence "deg_pm t  poly_deg q" by (rule poly_deg_max_keys)
    thus ?thesis by (simp add: le_max_iff_disj)
  qed
qed

lemma poly_deg_times_le:
  "poly_deg (p * q)  poly_deg p + poly_deg (q::(_ 0 'a::add_linorder_min) 0 _)"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (p * q)"
  then obtain u v where "u  keys p" and "v  keys q" and "t = u + v" by (rule in_keys_timesE)
  from u  keys p have "deg_pm u  poly_deg p" by (rule poly_deg_max_keys)
  moreover from v  keys q have "deg_pm v  poly_deg q" by (rule poly_deg_max_keys)
  ultimately show "deg_pm t  poly_deg p + poly_deg q" by (simp add: t = u + v deg_pm_plus add_mono)
qed

lemma poly_deg_times:
  assumes "p  0" and "q  (0::('x::linorder 0 'a::add_linorder_min) 0 'b::semiring_no_zero_divisors)"
  shows "poly_deg (p * q) = poly_deg p + poly_deg q"
  using poly_deg_times_le
proof (rule antisym)
  let ?A = "λf. {u. deg_pm u < poly_deg f}"
  define p1 where "p1 = except p (?A p)"
  define p2 where "p2 = except p (- ?A p)"
  define q1 where "q1 = except q (?A q)"
  define q2 where "q2 = except q (- ?A q)"
  have deg_p1: "deg_pm t = poly_deg p" if "t  keys p1" for t
  proof -
    from that have "t  keys p" and "poly_deg p  deg_pm t"
      by (simp_all add: p1_def keys_except not_less)
    from this(1) have "deg_pm t  poly_deg p" by (rule poly_deg_max_keys)
    thus ?thesis using ‹poly_deg p  deg_pm t by (rule antisym)
  qed
  have deg_p2: "t  keys p2  deg_pm t < poly_deg p" for t by (simp add: p2_def keys_except)
  have deg_q1: "deg_pm t = poly_deg q" if "t  keys q1" for t
  proof -
    from that have "t  keys q" and "poly_deg q  deg_pm t"
      by (simp_all add: q1_def keys_except not_less)
    from this(1) have "deg_pm t  poly_deg q" by (rule poly_deg_max_keys)
    thus ?thesis using ‹poly_deg q  deg_pm t by (rule antisym)
  qed
  have deg_q2: "t  keys q2  deg_pm t < poly_deg q" for t by (simp add: q2_def keys_except)
  have p: "p = p1 + p2" unfolding p1_def p2_def by (fact except_decomp)
  have "p1  0"
  proof -
    from assms(1) obtain t where "t  keys p" and "poly_deg p = deg_pm t" by (rule poly_degE)
    hence "t  keys p1" by (simp add: p1_def keys_except)
    thus ?thesis by auto
  qed
  have q: "q = q1 + q2" unfolding q1_def q2_def by (fact except_decomp)
  have "q1  0"
  proof -
    from assms(2) obtain t where "t  keys q" and "poly_deg q = deg_pm t" by (rule poly_degE)
    hence "t  keys q1" by (simp add: q1_def keys_except)
    thus ?thesis by auto
  qed
  with p1  0 have "p1 * q1  0" by simp
  hence "keys (p1 * q1)  {}" by simp
  then obtain u where "u  keys (p1 * q1)" by blast
  then obtain s t where "s  keys p1" and "t  keys q1" and u: "u = s + t" by (rule in_keys_timesE)
  from s  keys p1 have "deg_pm s = poly_deg p" by (rule deg_p1)
  moreover from t  keys q1 have "deg_pm t = poly_deg q" by (rule deg_q1)
  ultimately have eq: "poly_deg p + poly_deg q = deg_pm u" by (simp only: u deg_pm_plus)
  also have "  poly_deg (p * q)"
  proof (rule poly_deg_max_keys)
    have "u  keys (p1 * q2 + p2 * q)"
    proof
      assume "u  keys (p1 * q2 + p2 * q)"
      also have "  keys (p1 * q2)  keys (p2 * q)" by (rule Poly_Mapping.keys_add)
      finally have "deg_pm u < poly_deg p + poly_deg q"
      proof
        assume "u  keys (p1 * q2)"
        then obtain s' t' where "s'  keys p1" and "t'  keys q2" and u: "u = s' + t'"
          by (rule in_keys_timesE)
        from s'  keys p1 have "deg_pm s' = poly_deg p" by (rule deg_p1)
        moreover from t'  keys q2 have "deg_pm t' < poly_deg q" by (rule deg_q2)
        ultimately show ?thesis by (simp add: u deg_pm_plus)
      next
        assume "u  keys (p2 * q)"
        then obtain s' t' where "s'  keys p2" and "t'  keys q" and u: "u = s' + t'"
          by (rule in_keys_timesE)
        from s'  keys p2 have "deg_pm s' < poly_deg p" by (rule deg_p2)
        moreover from t'  keys q have "deg_pm t'  poly_deg q" by (rule poly_deg_max_keys)
        ultimately show ?thesis by (simp add: u deg_pm_plus add_less_le_mono)
      qed
      thus False by (simp only: eq)
    qed
    with u  keys (p1 * q1) have "u  keys (p1 * q1 + (p1 * q2 + p2 * q))" by (rule in_keys_plusI1)
    thus "u  keys (p * q)" by (simp only: p q algebra_simps)
  qed
  finally show "poly_deg p + poly_deg q  poly_deg (p * q)" .
qed

corollary poly_deg_monom_mult_le:
  "poly_deg (punit.monom_mult c (t::_ 0 'a::add_linorder_min) p)  deg_pm t + poly_deg p"
proof -
  have "poly_deg (punit.monom_mult c t p)  poly_deg (monomial c t) + poly_deg p"
    by (simp only: times_monomial_left[symmetric] poly_deg_times_le)
  also have "...  deg_pm t + poly_deg p" by (simp add: poly_deg_monomial)
  finally show ?thesis .
qed

lemma poly_deg_monom_mult:
  assumes "c  0" and "p  (0::(_ 0 'a::add_linorder_min) 0 'b::semiring_no_zero_divisors)"
  shows "poly_deg (punit.monom_mult c t p) = deg_pm t + poly_deg p"
proof (rule order.antisym, fact poly_deg_monom_mult_le)
  from assms(2) obtain s where "s  keys p" and "poly_deg p = deg_pm s" by (rule poly_degE)
  have "deg_pm t + poly_deg p = deg_pm (t + s)" by (simp add: ‹poly_deg p = deg_pm s deg_pm_plus)
  also have "...  poly_deg (punit.monom_mult c t p)"
  proof (rule poly_deg_max_keys)
    from s  keys p show "t + s  keys (punit.monom_mult c t p)"
      unfolding punit.keys_monom_mult[OF assms(1)] by fastforce
  qed
  finally show "deg_pm t + poly_deg p  poly_deg (punit.monom_mult c t p)" .
qed

lemma poly_deg_map_scale:
  "poly_deg (c  p) = (if c = (0::_::semiring_no_zero_divisors) then 0 else poly_deg p)"
  by (simp add: poly_deg_def keys_map_scale)

lemma poly_deg_sum_le: "((poly_deg (sum f A))::'a::add_linorder_min)  Max (poly_deg ` f ` A)"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    show ?case by simp
  next
    case (insert a A)
    show ?case
    proof (cases "A = {}")
      case True
      thus ?thesis by simp
    next
      case False
      have "poly_deg (sum f (insert a A))  max (poly_deg (f a)) (poly_deg (sum f A))"
        by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] poly_deg_plus_le)
      also have "...  max (poly_deg (f a)) (Max (poly_deg ` f ` A))"
        using insert(3) max.mono by blast
      also have "... = (Max (poly_deg ` f ` (insert a A)))" using False by (simp add: insert(1))
      finally show ?thesis .
    qed
  qed
next
  case False
  thus ?thesis by simp
qed

lemma poly_deg_prod_le: "((poly_deg (prod f A))::'a::add_linorder_min)  (aA. poly_deg (f a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    show ?case by simp
  next
    case (insert a A)
    have "poly_deg (prod f (insert a A))  (poly_deg (f a)) + (poly_deg (prod f A))"
      by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] poly_deg_times_le)
    also have "...  (poly_deg (f a)) + (aA. poly_deg (f a))"
      using insert(3) add_le_cancel_left by blast
    also have "... = (ainsert a A. poly_deg (f a))" by (simp add: insert(1) insert(2))
    finally show ?case .
  qed
next
  case False
  thus ?thesis by simp
qed

lemma maxdeg_max:
  assumes "finite A" and "p  A"
  shows "poly_deg p  maxdeg A"
  unfolding maxdeg_def using assms by auto

lemma mindeg_min:
  assumes "finite A" and "p  A"
  shows "mindeg A  poly_deg p"
  unfolding mindeg_def using assms by auto

subsection ‹Indeterminates›

definition indets :: "(('x 0 nat) 0 'b::zero)  'x set"
  where "indets p =  (keys ` keys p)"

definition PPs :: "'x set  ('x 0 nat) set"  (".[(_)]")
  where "PPs X = {t. keys t  X}"

definition Polys :: "'x set  (('x 0 nat) 0 'b::zero) set"  ("P[(_)]")
  where "Polys X = {p. keys p  .[X]}"

subsubsection @{const indets}

lemma in_indetsI:
  assumes "x  keys t" and "t  keys p"
  shows "x  indets p"
  using assms by (auto simp add: indets_def)

lemma in_indetsE:
  assumes "x  indets p"
  obtains t where "t  keys p" and "x  keys t"
  using assms by (auto simp add: indets_def)

lemma keys_subset_indets: "t  keys p  keys t  indets p"
  by (auto dest: in_indetsI)

lemma indets_empty_imp_monomial:
  assumes "indets p = {}"
  shows "monomial (lookup p 0) 0 = p"
proof (rule keys_subset_singleton_imp_monomial, rule)
  fix t
  assume "t  keys p"
  have "t = 0"
  proof (rule ccontr)
    assume "t  0"
    hence "keys t  {}" by simp
    then obtain x where "x  keys t" by blast
    from this t  keys p have "x  indets p" by (rule in_indetsI)
    with assms show False by simp
  qed
  thus "t  {0}" by simp
qed

lemma finite_indets: "finite (indets p)"
  by (simp only: indets_def, rule finite_UN_I, (rule finite_keys)+)

lemma indets_zero [simp]: "indets 0 = {}"
  by (simp add: indets_def)

lemma indets_one [simp]: "indets 1 = {}"
  by (simp add: indets_def)

lemma indets_monomial_single_subset: "indets (monomial c (Poly_Mapping.single v k))  {v}"
proof
  fix x assume "x  indets (monomial c (Poly_Mapping.single v k))"
  then have "x = v" unfolding indets_def
    by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
  thus "x  {v}" by simp
qed

lemma indets_monomial_single:
  assumes "c  0" and "k  0"
  shows "indets (monomial c (Poly_Mapping.single v k)) = {v}"
proof (rule, fact indets_monomial_single_subset, simp)
  from assms show "v  indets (monomial c (monomial k v))" by (simp add: indets_def)
qed

lemma indets_monomial:
  assumes "c  0"
  shows "indets (monomial c t) = keys t"
proof (rule antisym; rule subsetI)
  fix x
  assume "x  indets (monomial c t)"
  then have "lookup t x  0" unfolding indets_def
    by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
  thus "x  keys t" by (meson lookup_not_eq_zero_eq_in_keys)
next
  fix x
  assume "x  keys t"
  then have "lookup t x  0" by (meson lookup_not_eq_zero_eq_in_keys)
  thus "x  indets (monomial c t)" unfolding indets_def using assms
    by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq)
qed

lemma indets_monomial_subset: "indets (monomial c t)  keys t"
  by (cases "c = 0", simp_all add: indets_def)

lemma indets_monomial_zero [simp]: "indets (monomial c 0) = {}"
  by (simp add: indets_def)

lemma indets_plus_subset: "indets (p + q)  indets p  indets q"
proof
  fix x
  assume "x  indets (p + q)"
  then obtain t where "x  keys t" and "t  keys (p + q)" by (metis UN_E indets_def)
  hence "t  keys p  keys q" by (metis Poly_Mapping.keys_add subsetCE)
  thus "x  indets p  indets q" using indets_def x  keys t by fastforce
qed

lemma indets_uminus [simp]: "indets (-p) = indets p"
  by (simp add: indets_def keys_uminus)

lemma indets_minus_subset: "indets (p - q)  indets p  indets q"
proof
  fix x
  assume "x  indets (p - q)"
  then obtain t where "x  keys t" and "t  keys (p - q)" by (metis UN_E indets_def)
  hence "t  keys p  keys q" by (metis keys_minus subsetCE)
  thus "x  indets p  indets q" using indets_def x  keys t by fastforce
qed

lemma indets_times_subset: "indets (p * q)  indets p  indets (q::(_ 0 _::cancel_comm_monoid_add) 0 _)"
proof
  fix x
  assume "x  indets (p * q)"
  then obtain t where "t  keys (p * q)" and "x  keys t" unfolding indets_def by blast
  from this(1) obtain u v where "u  keys p" "v  keys q" and "t = u + v" by (rule in_keys_timesE)
  hence "x  keys u  keys v" by (metis x  keys t Poly_Mapping.keys_add subsetCE)
  thus "x  indets p  indets q" unfolding indets_def using u  keys p v  keys q by blast
qed

corollary indets_monom_mult_subset: "indets (punit.monom_mult c t p)  keys t  indets p"
proof -
  have "indets (punit.monom_mult c t p)  indets (monomial c t)  indets p"
    by (simp only: times_monomial_left[symmetric] indets_times_subset)
  also have "...  keys t  indets p" using indets_monomial_subset[of t c] by blast
  finally show ?thesis .
qed

lemma indets_monom_mult:
  assumes "c  0" and "p  (0::('x 0 nat) 0 'b::semiring_no_zero_divisors)"
  shows "indets (punit.monom_mult c t p) = keys t  indets p"
proof (rule, fact indets_monom_mult_subset, rule)
  fix x
  assume "x  keys t  indets p"
  thus "x  indets (punit.monom_mult c t p)"
  proof
    assume "x  keys t"
    from assms(2) have "keys p  {}" by simp
    then obtain s where "s  keys p" by blast
    hence "t + s  (+) t ` keys p" by fastforce
    also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
    finally have "t + s  keys (punit.monom_mult c t p)" .
    show ?thesis
    proof (rule in_indetsI)
      from x  keys t show "x  keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
    qed fact
  next
    assume "x  indets p"
    then obtain s where "s  keys p" and "x  keys s" by (rule in_indetsE)
    from this(1) have "t + s  (+) t ` keys p" by fastforce
    also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
    finally have "t + s  keys (punit.monom_mult c t p)" .
    show ?thesis
    proof (rule in_indetsI)
      from x  keys s show "x  keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
    qed fact
  qed
qed

lemma indets_sum_subset: "indets (sum f A)  (aA. indets (f a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    show ?case by simp
  next
    case (insert a A)
    have "indets (sum f (insert a A))  indets (f a)  indets (sum f A)"
      by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] indets_plus_subset)
    also have "...  indets (f a)  (aA. indets (f a))" using insert(3) by blast
    also have "... = (ainsert a A. indets (f a))" by simp
    finally show ?case .
  qed
next
  case False
  thus ?thesis by simp
qed

lemma indets_prod_subset:
  "indets (prod (f::_  ((_ 0 _::cancel_comm_monoid_add) 0 _)) A)  (aA. indets (f a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof (induct A)
    case empty
    show ?case by simp
  next
    case (insert a A)
    have "indets (prod f (insert a A))  indets (f a)  indets (prod f A)"
      by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] indets_times_subset)
    also have "...  indets (f a)  (aA. indets (f a))" using insert(3) by blast
    also have "... = (ainsert a A. indets (f a))" by simp
    finally show ?case .
  qed
next
  case False
  thus ?thesis by simp
qed

lemma indets_power_subset: "indets (p ^ n)  indets (p::('x 0 nat) 0 'b::comm_semiring_1)"
proof -
  have "p ^ n = (i=0..<n. p)" by simp
  also have "indets ...  (i{0..<n}. indets p)" by (fact indets_prod_subset)
  also have "...  indets p" by simp
  finally show ?thesis .
qed

lemma indets_empty_iff_poly_deg_zero: "indets p = {}  poly_deg p = 0"
proof
  assume "indets p = {}"
  hence "monomial (lookup p 0) 0 = p" by (rule indets_empty_imp_monomial)
  moreover have "poly_deg (monomial (lookup p 0) 0) = 0" by simp
  ultimately show "poly_deg p = 0" by metis
next
  assume "poly_deg p = 0"
  hence "monomial (lookup p 0) 0 = p" by (rule poly_deg_zero_imp_monomial)
  moreover have "indets (monomial (lookup p 0) 0) = {}" by simp
  ultimately show "indets p = {}" by metis
qed

subsubsection @{const PPs}

lemma PPsI: "keys t  X  t  .[X]"
  by (simp add: PPs_def)

lemma PPsD: "t  .[X]  keys t  X"
  by (simp add: PPs_def)

lemma PPs_empty [simp]: ".[{}] = {0}"
  by (simp add: PPs_def)

lemma PPs_UNIV [simp]: ".[UNIV] = UNIV"
  by (simp add: PPs_def)

lemma PPs_singleton: ".[{x}] = range (Poly_Mapping.single x)"
proof (rule set_eqI)
  fix t
  show "t  .[{x}]  t  range (Poly_Mapping.single x)"
  proof
    assume "t  .[{x}]"
    hence "keys t  {x}" by (rule PPsD)
    hence "Poly_Mapping.single x (lookup t x) = t" by (rule keys_subset_singleton_imp_monomial)
    from this[symmetric] UNIV_I show "t  range (Poly_Mapping.single x)" ..
  next
    assume "t  range (Poly_Mapping.single x)"
    then obtain e where "t = Poly_Mapping.single x e" ..
    thus "t  .[{x}]" by (simp add: PPs_def)
  qed
qed

lemma zero_in_PPs: "0  .[X]"
  by (simp add: PPs_def)

lemma PPs_mono: "X  Y  .[X]  .[Y]"
  by (auto simp: PPs_def)

lemma PPs_closed_single:
  assumes "x  X"
  shows "Poly_Mapping.single x e  .[X]"
proof (rule PPsI)
  have "keys (Poly_Mapping.single x e)  {x}" by simp
  also from assms have "...  X" by simp
  finally show "keys (Poly_Mapping.single x e)  X" .
qed

lemma PPs_closed_plus:
  assumes "s  .[X]" and "t  .[X]"
  shows "s + t  .[X]"
proof -
  have "keys (s + t)  keys s  keys t" by (fact Poly_Mapping.keys_add)
  also from assms have "...  X" by (simp add: PPs_def)
  finally show ?thesis by (rule PPsI)
qed

lemma PPs_closed_minus:
  assumes "s  .[X]"
  shows "s - t  .[X]"
proof -
  have "keys (s - t)  keys s" by (metis lookup_minus lookup_not_eq_zero_eq_in_keys subsetI zero_diff)
  also from assms have "...  X" by (rule PPsD)
  finally show ?thesis by (rule PPsI)
qed

lemma PPs_closed_adds:
  assumes "s  .[X]" and "t adds s"
  shows "t  .[X]"
proof -
  from assms(2) have "s - (s - t) = t" by (metis add_minus_2 adds_minus)
  moreover from assms(1) have "s - (s - t)  .[X]" by (rule PPs_closed_minus)
  ultimately show ?thesis by simp
qed

lemma PPs_closed_gcs:
  assumes "s  .[X]"
  shows "gcs s t  .[X]"
  using assms gcs_adds by (rule PPs_closed_adds)

lemma PPs_closed_lcs:
  assumes "s  .[X]" and "t  .[X]"
  shows "lcs s t  .[X]"
proof -
  from assms have "s + t  .[X]" by (rule PPs_closed_plus)
  hence "(s + t) - gcs s t  .[X]" by (rule PPs_closed_minus)
  thus ?thesis by (simp add: gcs_plus_lcs[of s t, symmetric])
qed

lemma PPs_closed_except': "t  .[X]  except t Y  .[X - Y]"
  by (auto simp: keys_except PPs_def)

lemma PPs_closed_except: "t  .[X]  except t Y  .[X]"
  by (auto simp: keys_except PPs_def)

lemma PPs_UnI:
  assumes "tx  .[X]" and "ty  .[Y]" and "t = tx + ty"
  shows "t  .[X  Y]"
proof -
  from assms(1) have "tx  .[X  Y]" by rule (simp add: PPs_mono)
  moreover from assms(2) have "ty  .[X  Y]" by rule (simp add: PPs_mono)
  ultimately show ?thesis unfolding assms(3) by (rule PPs_closed_plus)
qed

lemma PPs_UnE:
  assumes "t  .[X  Y]"
  obtains tx ty where "tx  .[X]" and "ty  .[Y]" and "t = tx + ty"
proof -
  from assms have "keys t  X  Y" by (rule PPsD)
  define tx where "tx = except t (- X)"
  have "keys tx  X" by (simp add: tx_def keys_except)
  hence "tx  .[X]" by (simp add: PPs_def)
  have "tx adds t" by (simp add: tx_def adds_poly_mappingI le_fun_def lookup_except)
  from adds_minus[OF this] have "t = tx + (t - tx)" by (simp only: ac_simps)
  have "t - tx  .[Y]"
  proof (rule PPsI, rule)
    fix x
    assume "x  keys (t - tx)"
    also have "...  keys t  keys tx" by (rule keys_minus)
    also from ‹keys t  X  Y ‹keys tx  X have "...  X  Y" by blast
    finally show "x  Y"
    proof
      assume "x  X"
      hence "x  keys (t - tx)" by (simp add: tx_def lookup_except lookup_minus in_keys_iff)
      thus ?thesis using x  keys (t - tx) ..
    qed
  qed
  with tx  .[X] show ?thesis using t = tx + (t - tx) ..
qed

lemma PPs_Un: ".[X  Y] = (t.[X]. (+) t ` .[Y])"  (is "?A = ?B")
proof (rule set_eqI)
  fix t
  show "t  ?A  t  ?B"
  proof
    assume "t  ?A"
    then obtain tx ty where "tx  .[X]" and "ty  .[Y]" and "t = tx + ty" by (rule PPs_UnE)
    from this(2) have "t  (+) tx ` .[Y]" unfolding t = tx + ty by (rule imageI)
    with tx  .[X] show "t  ?B" ..
  next
    assume "t  ?B"
    then obtain tx where "tx  .[X]" and "t  (+) tx ` .[Y]" ..
    from this(2) obtain ty where "ty  .[Y]" and "t = tx + ty" ..
    with tx  .[X] show "t  ?A" by (rule PPs_UnI)
  qed
qed

corollary PPs_insert: ".[insert x X] = (e. (+) (Poly_Mapping.single x e) ` .[X])"
proof -
  have ".[insert x X] = .[{x}  X]" by simp
  also have "... = (t.[{x}]. (+) t ` .[X])" by (fact PPs_Un)
  also have "... = (e. (+) (Poly_Mapping.single x e) ` .[X])" by (simp add: PPs_singleton)
  finally show ?thesis .
qed

corollary PPs_insertI:
  assumes "tx  .[X]" and "t = Poly_Mapping.single x e + tx"
  shows "t  .[insert x X]"
proof -
  from assms(1) have "t  (+) (Poly_Mapping.single x e) ` .[X]" unfolding assms(2) by (rule imageI)
  with UNIV_I show ?thesis unfolding PPs_insert by (rule UN_I)
qed

corollary PPs_insertE:
  assumes "t  .[insert x X]"
  obtains e tx where "tx  .[X]" and "t = Poly_Mapping.single x e + tx"
proof -
  from assms obtain e where "t  (+) (Poly_Mapping.single x e) ` .[X]" unfolding PPs_insert ..
  then obtain tx where "tx  .[X]" and "t = Poly_Mapping.single x e + tx" ..
  thus ?thesis ..
qed

lemma PPs_Int: ".[X  Y] = .[X]  .[Y]"
  by (auto simp: PPs_def)

lemma PPs_INT: ".[ X] =  (PPs ` X)"
  by (auto simp: PPs_def)

subsubsection @{const Polys}

lemma Polys_alt: "P[X] = {p. indets p  X}"
  by (auto simp: Polys_def PPs_def indets_def)

lemma PolysI: "keys p  .[X]  p  P[X]"
  by (simp add: Polys_def)

lemma PolysI_alt: "indets p  X  p  P[X]"
  by (simp add: Polys_alt)

lemma PolysD:
  assumes "p  P[X]"
  shows "keys p  .[X]" and "indets p  X"
  using assms by (simp add: Polys_def, simp add: Polys_alt)

lemma Polys_empty: "P[{}] = ((range (Poly_Mapping.single 0))::(('x 0 nat) 0 'b::zero) set)"
proof (rule set_eqI)
  fix p :: "('x 0 nat) 0 'b::zero"
  show "p  P[{}]  p  range (Poly_Mapping.single 0)"
  proof
    assume "p  P[{}]"
    hence "keys p  .[{}]" by (rule PolysD)
    also have "... = {0}" by simp
    finally have "keys p  {0}" .
    hence "Poly_Mapping.single 0 (lookup p 0) = p" by (rule keys_subset_singleton_imp_monomial)
    from this[symmetric] UNIV_I show "p  range (Poly_Mapping.single 0)" ..
  next
    assume "p  range (Poly_Mapping.single 0)"
    then obtain c where "p = monomial c 0" ..
    thus "p  P[{}]" by (simp add: Polys_def)
  qed
qed

lemma Polys_UNIV [simp]: "P[UNIV] = UNIV"
  by (simp add: Polys_def)

lemma zero_in_Polys: "0  P[X]"
  by (simp add: Polys_def)

lemma one_in_Polys: "1  P[X]"
  by (simp add: Polys_def zero_in_PPs)

lemma Polys_mono: "X  Y  P[X]  P[Y]"
  by (auto simp: Polys_alt)

lemma Polys_closed_monomial: "t  .[X]  monomial c t  P[X]"
  using indets_monomial_subset[where c=c and t=t] by (auto simp: Polys_alt PPs_def)

lemma Polys_closed_plus: "p  P[X]  q  P[X]  p + q  P[X]"
  using indets_plus_subset[of p q] by (auto simp: Polys_alt PPs_def)

lemma Polys_closed_uminus: "p  P[X]  -p  P[X]"
  by (simp add: Polys_def keys_uminus)

lemma Polys_closed_minus: "p  P[X]  q  P[X]  p - q  P[X]"
  using indets_minus_subset[of p q] by (auto simp: Polys_alt PPs_def)

lemma Polys_closed_monom_mult: "t  .[X]  p  P[X]  punit.monom_mult c t p  P[X]"
  using indets_monom_mult_subset[of c t p] by (auto simp: Polys_alt PPs_def)

corollary Polys_closed_map_scale: "p  P[X]  (c::_::semiring_0)  p  P[X]"
  unfolding punit.map_scale_eq_monom_mult using zero_in_PPs by (rule Polys_closed_monom_mult)

lemma Polys_closed_times: "p  P[X]  q  P[X]  p * q  P[X]"
  using indets_times_subset[of p q] by (auto simp: Polys_alt PPs_def)

lemma Polys_closed_power: "p  P[X]  p ^ m  P[X]"
  by (induct m) (auto intro: one_in_Polys Polys_closed_times)

lemma Polys_closed_sum: "(a. a  A  f a  P[X])  sum f A  P[X]"
  by (induct A rule: infinite_finite_induct) (auto intro: zero_in_Polys Polys_closed_plus)

lemma Polys_closed_prod: "(a. a  A  f a  P[X])  prod f A  P[X]"
  by (induct A rule: infinite_finite_induct) (auto intro: one_in_Polys Polys_closed_times)

lemma Polys_closed_sum_list: "(x. x  set xs  x  P[X])  sum_list xs  P[X]"
  by (induct xs) (auto intro: zero_in_Polys Polys_closed_plus)

lemma Polys_closed_except: "p  P[X]  except p T  P[X]"
  by (auto intro!: PolysI simp: keys_except dest!: PolysD(1))

lemma times_in_PolysD:
  assumes "p * q  P[X]" and "p  P[X]" and "p  (0::('x::linorder 0 nat) 0 'a::semiring_no_zero_divisors)"
  shows "q  P[X]"
proof -
  define qX where "qX = except q (- .[X])"
  define qY where "qY = except q .[X]"
  have q: "q = qX + qY" by (simp only: qX_def qY_def add.commute flip: except_decomp)
  have "qX  P[X]" by (rule PolysI) (simp add: qX_def keys_except)
  with assms(2) have "p * qX  P[X]" by (rule Polys_closed_times)
  show ?thesis
  proof (cases "qY = 0")
    case True
    with qX  P[X] show ?thesis by (simp add: q)
  next
    case False
    with assms(3) have "p * qY  0" by simp
    hence "keys (p * qY)  {}" by simp
    then obtain t where "t  keys (p * qY)" by blast
    then obtain t1 t2 where "t2  keys qY" and t: "t = t1 + t2" by (rule in_keys_timesE)
    have "t  .[X]" unfolding t
    proof
      assume "t1 + t2  .[X]"
      hence "t1 + t2 - t1  .[X]" by (rule PPs_closed_minus)
      hence "t2  .[X]" by simp
      with t2  keys qY show False by (simp add: qY_def keys_except)
    qed
    have "t  keys (p * qX)"
    proof
      assume "t  keys (p * qX)"
      also from p * qX  P[X] have "  .[X]" by (rule PolysD)
      finally have "t  .[X]" .
      with t  .[X] show False ..
    qed
    with t  keys (p * qY) have "t  keys (p * qX + p * qY)" by (rule in_keys_plusI2)
    also have " = keys (p * q)" by (simp only: q algebra_simps)
    finally have "p * q  P[X]" using t  .[X] by (auto simp: Polys_def)
    thus ?thesis using assms(1) ..
  qed
qed

lemma poly_mapping_plus_induct_Polys [consumes 1, case_names 0 plus]:
  assumes "p  P[X]" and "P 0"
    and "p c t. t  .[X]  p  P[X]  c  0  t  keys p  P p  P (monomial c t + p)"
  shows "P p"
  using assms(1)
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by (fact assms(2))
next
  case step: (2 p c t)
  from step.hyps(1) have 1: "keys (monomial c t) = {t}" by simp
  also from step.hyps(2) have "  keys p = {}" by simp
  finally have "keys (monomial c t + p) = keys (monomial c t)  keys p" by (rule keys_add[symmetric])
  hence "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
  moreover from step.prems(1) have "keys (monomial c t + p)  .[X]" by (rule PolysD)
  ultimately have "t  .[X]" and "keys p  .[X]" by blast+
  from this(2) have "p  P[X]" by (rule PolysI)
  hence "P p" by (rule step.hyps)
  with t  .[X] p  P[X] step.hyps(1, 2) show ?case by (rule assms(3))
qed

lemma Polys_Int: "P[X  Y] = P[X]  P[Y]"
  by (auto simp: Polys_def PPs_Int)

lemma Polys_INT: "P[ X] =  (Polys ` X)"
  by (auto simp: Polys_def PPs_INT)

subsection ‹Substitution Homomorphism›

text ‹The substitution homomorphism defined here is more general than @{const insertion}, since
  it replaces indeterminates by @{emph ‹polynomials›} rather than coefficients, and therefore
  constructs new polynomials.›

definition subst_pp :: "('x  (('y 0 nat) 0 'a))  ('x 0 nat)  (('y 0 nat) 0 'a::comm_semiring_1)"
  where "subst_pp f t = (xkeys t. (f x) ^ (lookup t x))"

definition poly_subst :: "('x  (('y 0 nat) 0 'a))  (('x 0 nat) 0 'a)  (('y 0 nat) 0 'a::comm_semiring_1)"
  where "poly_subst f p = (tkeys p. punit.monom_mult (lookup p t) 0 (subst_pp f t))"

lemma subst_pp_alt: "subst_pp f t = (x. (f x) ^ (lookup t x))"
proof -
  from finite_keys have "subst_pp f t = (x. if x  keys t then (f x) ^ (lookup t x) else 1)"
    unfolding subst_pp_def by (rule Prod_any.conditionalize)
  also have "... = (x. (f x) ^ (lookup t x))" by (rule Prod_any.cong) (simp add: in_keys_iff)
  finally show ?thesis .
qed

lemma subst_pp_zero [simp]: "subst_pp f 0 = 1"
  by (simp add: subst_pp_def)

lemma subst_pp_trivial_not_zero:
  assumes "t  0"
  shows "subst_pp (λ_. 0) t = (0::(_ 0 'b::comm_semiring_1))"
  unfolding subst_pp_def using finite_keys
proof (rule prod_zero)
  from assms have "keys t  {}" by simp
  then obtain x where "x  keys t" by blast
  thus "xkeys t. 0 ^ lookup t x = (0::(_ 0 'b))"
  proof
    from x  keys t have "0 < lookup t x" by (simp add: in_keys_iff)
    thus "0 ^ lookup t x = (0::(_ 0 'b))" by (rule Power.semiring_1_class.zero_power)
  qed
qed

lemma subst_pp_single: "subst_pp f (Poly_Mapping.single x e) = (f x) ^ e"
  by (simp add: subst_pp_def)

corollary subst_pp_trivial: "subst_pp (λ_. 0) t = (if t = 0 then 1 else 0)"
  by (simp split: if_split add: subst_pp_trivial_not_zero)

lemma power_lookup_not_one_subset_keys: "{x. f x ^ (lookup t x)  1}  keys t"
proof (rule, simp)
  fix x
  assume "f x ^ (lookup t x)  1"
  thus "x  keys t" unfolding in_keys_iff by (metis power_0)
qed

corollary finite_power_lookup_not_one: "finite {x. f x ^ (lookup t x)  1}"
  by (rule finite_subset, fact power_lookup_not_one_subset_keys, fact finite_keys)

lemma subst_pp_plus: "subst_pp f (s + t) = subst_pp f s * subst_pp f t"
  by (simp add: subst_pp_alt lookup_add power_add, rule Prod_any.distrib, (fact finite_power_lookup_not_one)+)

lemma subst_pp_id:
  assumes "x. x  keys t  f x = monomial 1 (Poly_Mapping.single x 1)"
  shows "subst_pp f t = monomial 1 t"
proof -
  have "subst_pp f t = (xkeys t. monomial 1 (Poly_Mapping.single x (lookup t x)))"
  proof (simp only: subst_pp_def, rule prod.cong, fact refl)
    fix x
    assume "x  keys t"
    thus "f x ^ lookup t x = monomial 1 (Poly_Mapping.single x (lookup t x))"
      by (simp add: assms monomial_single_power)
  qed
  also have "... = monomial 1 t"
    by (simp add: punit.monomial_prod_sum[symmetric] poly_mapping_sum_monomials)
  finally show ?thesis .
qed

lemma in_indets_subst_ppE:
  assumes "x  indets (subst_pp f t)"
  obtains y where "y  keys t" and "x  indets (f y)"
proof -
  note assms
  also have "indets (subst_pp f t)  (ykeys t. indets ((f y) ^ (lookup t y)))" unfolding subst_pp_def
    by (rule indets_prod_subset)
  finally obtain y where "y  keys t" and "x  indets ((f y) ^ (lookup t y))" ..
  note this(2)
  also have "indets ((f y) ^ (lookup t y))  indets (f y)" by (rule indets_power_subset)
  finally have "x  indets (f y)" .
  with y  keys t show ?thesis ..
qed

lemma subst_pp_by_monomials:
  assumes "y. y  keys t  f y = monomial (c y) (s y)"
  shows "subst_pp f t = monomial (ykeys t. (c y) ^ lookup t y) (ykeys t. lookup t y  s y)"
  by (simp add: subst_pp_def assms monomial_power_map_scale punit.monomial_prod_sum)

lemma poly_deg_subst_pp_eq_zeroI:
  assumes "x. x  keys t  poly_deg (f x) = 0"
  shows "poly_deg (subst_pp f t) = 0"
proof -
  have "poly_deg (subst_pp f t)  (xkeys t. poly_deg ((f x) ^ (lookup t x)))"
    unfolding subst_pp_def by (fact poly_deg_prod_le)
  also have "... = 0"
  proof (rule sum.neutral, rule)
    fix x
    assume "x  keys t"
    hence "poly_deg (f x) = 0" by (rule assms)
    have "f x ^ lookup t x = (i=0..<lookup t x. f x)" by simp
    also have "poly_deg ...  (i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
    also have "... = 0" by (simp add: ‹poly_deg (f x) = 0)
    finally show "poly_deg (f x ^ lookup t x) = 0" by simp
  qed
  finally show ?thesis by simp
qed

lemma poly_deg_subst_pp_le:
  assumes "x. x  keys t  poly_deg (f x)  1"
  shows "poly_deg (subst_pp f t)  deg_pm t"
proof -
  have "poly_deg (subst_pp f t)  (xkeys t. poly_deg ((f x) ^ (lookup t x)))"
    unfolding subst_pp_def by (fact poly_deg_prod_le)
  also have "...  (xkeys t. lookup t x)"
  proof (rule sum_mono)
    fix x
    assume "x  keys t"
    hence "poly_deg (f x)  1" by (rule assms)
    have "f x ^ lookup t x = (i=0..<lookup t x. f x)" by simp
    also have "poly_deg ...  (i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
    also from ‹poly_deg (f x)  1 have "...  (i=0..<lookup t x. 1)" by (rule sum_mono)
    finally show "poly_deg (f x ^ lookup t x)  lookup t x" by simp
  qed
  also have "... = deg_pm t" by (rule deg_pm_superset[symmetric], fact subset_refl, fact finite_keys)
  finally show ?thesis by simp
qed

lemma poly_subst_alt: "poly_subst f p = (t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
proof -
  from finite_keys have "poly_subst f p = (t. if t  keys p then punit.monom_mult (lookup p t) 0 (subst_pp f t) else 0)"
    unfolding poly_subst_def by (rule Sum_any.conditionalize)
  also have " = (t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
    by (rule Sum_any.cong) (simp add: in_keys_iff)
  finally show ?thesis .
qed

lemma poly_subst_trivial [simp]: "poly_subst (λ_. 0) p = monomial (lookup p 0) 0"
  by (simp add: poly_subst_def subst_pp_trivial if_distrib in_keys_iff cong: if_cong)
      (metis mult.right_neutral times_monomial_left)

lemma poly_subst_zero [simp]: "poly_subst f 0 = 0"
  by (simp add: poly_subst_def)

lemma monom_mult_lookup_not_zero_subset_keys:
  "{t. punit.monom_mult (lookup p t) 0 (subst_pp f t)  0}  keys p"
proof (rule, simp)
  fix t
  assume "punit.monom_mult (lookup p t) 0 (subst_pp f t)  0"
  thus "t  keys p" unfolding in_keys_iff by (metis punit.monom_mult_zero_left)
qed

corollary finite_monom_mult_lookup_not_zero:
  "finite {t. punit.monom_mult (lookup p t) 0 (subst_pp f t)  0}"
  by (rule finite_subset, fact monom_mult_lookup_not_zero_subset_keys, fact finite_keys)

lemma poly_subst_plus: "poly_subst f (p + q) = poly_subst f p + poly_subst f q"
  by (simp add: poly_subst_alt lookup_add punit.monom_mult_dist_left, rule Sum_any.distrib,
      (fact finite_monom_mult_lookup_not_zero)+)

lemma poly_subst_uminus: "poly_subst f (-p) = - poly_subst f (p::('x 0 nat) 0 'b::comm_ring_1)"
  by (simp add: poly_subst_def keys_uminus punit.monom_mult_uminus_left sum_negf)

lemma poly_subst_minus:
  "poly_subst f (p - q) = poly_subst f p - poly_subst f (q::('x 0 nat) 0 'b::comm_ring_1)"
proof -
  have "poly_subst f (p + (-q)) = poly_subst f p + poly_subst f (-q)" by (fact poly_subst_plus)
  thus ?thesis by (simp add: poly_subst_uminus)
qed

lemma poly_subst_monomial: "poly_subst f (monomial c t) = punit.monom_mult c 0 (subst_pp f t)"
  by (simp add: poly_subst_def lookup_single)

corollary poly_subst_one [simp]: "poly_subst f 1 = 1"
  by (simp add: single_one[symmetric] poly_subst_monomial punit.monom_mult_monomial del: single_one)

lemma poly_subst_times: "poly_subst f (p * q) = poly_subst f p * poly_subst f q"
proof -
  have bij: "bij (λ(l, n, m). (m, l, n))"
    by (auto intro!: bijI injI simp add: image_def)
  let ?P = "keys p"
  let ?Q = "keys q"
  let ?PQ = "{s + t | s t. lookup p s  0  lookup q t  0}"
  have fin_PQ: "finite ?PQ"
    by (rule finite_not_eq_zero_sumI, simp_all)
  have fin_1: "finite {l. lookup p l * (qa. lookup q qa when t = l + qa)  0}" for t
  proof (rule finite_subset)
    show "{l. lookup p l * (qa. lookup q qa when t = l + qa)  0}  keys p"
      by (rule, auto simp: in_keys_iff)
  qed (fact finite_keys)
  have fin_2: "finite {v. (lookup q v when t = u + v)  0}" for t u
  proof (rule finite_subset)
    show "{v. (lookup q v when t = u + v)  0}  keys q"
      by (rule, auto simp: in_keys_iff)
  qed (fact finite_keys)
  have fin_3: "finite {v. (lookup p u * lookup q v when t = u + v)  0}" for t u
  proof (rule finite_subset)
    show "{v. (lookup p u * lookup q v when t = u + v)  0}  keys q"
      by (rule, auto simp add: in_keys_iff simp del: lookup_not_eq_zero_eq_in_keys)
  qed (fact finite_keys)
  have "(t. punit.monom_mult (lookup (p * q) t) 0 (subst_pp f t)) =
        (t. u. punit.monom_mult (lookup p u * (v. lookup q v when t = u + v)) 0 (subst_pp f t))"
    by (simp add: times_poly_mapping.rep_eq prod_fun_def punit.monom_mult_Sum_any_left[OF fin_1])
  also have " = (t. u. v. (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v)"
    by (simp add: Sum_any_right_distrib[OF fin_2] punit.monom_mult_Sum_any_left[OF fin_3] mult_when punit.when_monom_mult)
  also have " = (t. ((u, v). (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v))"
    by (subst (2) Sum_any.cartesian_product [of "?P × ?Q"]) (auto simp: in_keys_iff)
  also have " = ((t, u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
    apply (subst Sum_any.cartesian_product [of "?PQ × (?P × ?Q)"])
    apply (auto simp: fin_PQ in_keys_iff)
    apply (metis monomial_0I mult_not_zero times_monomial_left)
    done
  also have " = ((u, v, t). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
    using bij by (rule Sum_any.reindex_cong [of "λ(u, v, t). (t, u, v)"]) (simp add: fun_eq_iff)
  also have " = ((u, v). t. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
    apply (subst Sum_any.cartesian_product2 [of "(?P × ?Q) × ?PQ"])
    apply (auto simp: fin_PQ in_keys_iff)
    apply (metis monomial_0I mult_not_zero times_monomial_left)
    done
  also have " = ((u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
    by (simp add: subst_pp_plus)
  also have " = (u. v. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
    by (subst Sum_any.cartesian_product [of "?P × ?Q"]) (auto simp: in_keys_iff)
  also have " = (u. v. (punit.monom_mult (lookup p u) 0 (subst_pp f u)) * (punit.monom_mult (lookup q v) 0 (subst_pp f v)))"
    by (simp add: times_monomial_left[symmetric] ac_simps mult_single)
  also have " = (t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) *
                  (t. punit.monom_mult (lookup q t) 0 (subst_pp f t))"
    by (rule Sum_any_product [symmetric], (fact finite_monom_mult_lookup_not_zero)+)
  finally show ?thesis by (simp add: poly_subst_alt)
qed

corollary poly_subst_monom_mult:
  "poly_subst f (punit.monom_mult c t p) = punit.monom_mult c 0 (subst_pp f t * poly_subst f p)"
  by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial mult.assoc)

corollary poly_subst_monom_mult':
  "poly_subst f (punit.monom_mult c t p) = (punit.monom_mult c 0 (subst_pp f t)) * poly_subst f p"
  by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial)

lemma poly_subst_sum: "poly_subst f (sum p A) = (aA. poly_subst f (p a))"
  by (rule fun_sum_commute, simp_all add: poly_subst_plus)

lemma poly_subst_prod: "poly_subst f (prod p A) = (aA. poly_subst f (p a))"
  by (rule fun_prod_commute, simp_all add: poly_subst_times)

lemma poly_subst_power: "poly_subst f (p ^ n) = (poly_subst f p) ^ n"
  by (induct n, simp_all add: poly_subst_times)

lemma poly_subst_subst_pp: "poly_subst f (subst_pp g t) = subst_pp (λx. poly_subst f (g x)) t"
  by (simp only: subst_pp_def poly_subst_prod poly_subst_power)

lemma poly_subst_poly_subst: "poly_subst f (poly_subst g p) = poly_subst (λx. poly_subst f (g x)) p"
proof -
  have "poly_subst f (poly_subst g p) =
          poly_subst f (tkeys p. punit.monom_mult (lookup p t) 0 (subst_pp g t))"
    by (simp only: poly_subst_def)
  also have " = (tkeys p. punit.monom_mult (lookup p t) 0 (subst_pp (λx. poly_subst f (g x)) t))"
    by (simp add: poly_subst_sum poly_subst_monom_mult poly_subst_subst_pp)
  also have " = poly_subst (λx. poly_subst f (g x)) p" by (simp only: poly_subst_def)
  finally show ?thesis .
qed

lemma poly_subst_id:
  assumes "x. x  indets p  f x = monomial 1 (Poly_Mapping.single x 1)"
  shows "poly_subst f p = p"
proof -
  have "poly_subst f p = (tkeys p. monomial (lookup p t) t)"
  proof (simp only: poly_subst_def, rule sum.cong, fact refl)
    fix t
    assume "t  keys p"
    have eq: "subst_pp f t = monomial 1 t"
      by (rule subst_pp_id, rule assms, erule in_indetsI, fact t  keys p)
    show "punit.monom_mult (lookup p t) 0 (subst_pp f t) = monomial (lookup p t) t"
      by (simp add: eq punit.monom_mult_monomial)
  qed
  also have "... = p" by (simp only: poly_mapping_sum_monomials)
  finally show ?thesis .
qed

lemma in_keys_poly_substE:
  assumes "t  keys (poly_subst f p)"
  obtains s where "s  keys p" and "t  keys (subst_pp f s)"
proof -
  note assms
  also have "keys (poly_subst f p)  (tkeys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
    unfolding poly_subst_def by (rule keys_sum_subset)
  finally obtain s where "s  keys p" and "t  keys (punit.monom_mult (lookup p s) 0 (subst_pp f s))" ..
  note this(2)
  also have "  (+) 0 ` keys (subst_pp f s)" by (rule punit.keys_monom_mult_subset[simplified])
  also have " = keys (subst_pp f s)" by simp
  finally have "t  keys (subst_pp f s)" .
  with s  keys p show ?thesis ..
qed

lemma in_indets_poly_substE:
  assumes "x  indets (poly_subst f p)"
  obtains y where "y  indets p" and "x  indets (f y)"
proof -
  note assms
  also have "indets (poly_subst f p)  (tkeys p. indets (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
    unfolding poly_subst_def by (rule indets_sum_subset)
  finally obtain t where "t  keys p" and "x  indets (punit.monom_mult (lookup p t) 0 (subst_pp f t))" ..
  note this(2)
  also have "indets (punit.monom_mult (lookup p t) 0 (subst_pp f t))  keys (0::('a 0 nat))  indets (subst_pp f t)"
    by (rule indets_monom_mult_subset)
  also have "... = indets (subst_pp f t)" by simp
  finally obtain y where "y  keys t" and "x  indets (f y)" by (rule in_indets_subst_ppE)
  from this(1) t  keys p have "y  indets p" by (rule in_indetsI)
  from this x  indets (f y) show ?thesis ..
qed

lemma poly_deg_poly_subst_eq_zeroI:
  assumes "x. x  indets p  poly_deg (f x) = 0"
  shows "poly_deg (poly_subst (f::_  (('y 0 _) 0 _)) (p::('x 0 _) 0 'b::comm_semiring_1)) = 0"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  have "poly_deg (poly_subst f p)  Max (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
    unfolding poly_subst_def by (fact poly_deg_sum_le)
  also have "...  0"
  proof (rule Max.boundedI)
    show "finite (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
      by (simp add: finite_image_iff)
  next
    from False show "poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p  {}" by simp
  next
    fix d
    assume "d  poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
    then obtain t where "t  keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
      by fastforce
    have "d  deg_pm (0::'y 0 nat) + poly_deg (subst_pp f t)"
      unfolding d by (fact poly_deg_monom_mult_le)
    also have "... = poly_deg (subst_pp f t)" by simp
    also have "... = 0" by (rule poly_deg_subst_pp_eq_zeroI, rule assms, erule in_indetsI, fact)
    finally show "d  0" .
  qed
  finally show ?thesis by simp
qed

lemma poly_deg_poly_subst_le:
  assumes "x. x  indets p  poly_deg (f x)  1"
  shows "poly_deg (poly_subst (f::_  (('y 0 _) 0 _)) (p::('x 0 nat) 0 'b::comm_semiring_1))  poly_deg p"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  have "poly_deg (poly_subst f p)  Max (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
    unfolding poly_subst_def by (fact poly_deg_sum_le)
  also have "...  poly_deg p"
  proof (rule Max.boundedI)
    show "finite (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
      by (simp add: finite_image_iff)
  next
    from False show "poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p  {}" by simp
  next
    fix d
    assume "d  poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
    then obtain t where "t  keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
      by fastforce
    have "d  deg_pm (0::'y 0 nat) + poly_deg (subst_pp f t)"
      unfolding d by (fact poly_deg_monom_mult_le)
    also have "... = poly_deg (subst_pp f t)" by simp
    also have "...  deg_pm t" by (rule poly_deg_subst_pp_le, rule assms, erule in_indetsI, fact)
    also from t  keys p have "...  poly_deg p" by (rule poly_deg_max_keys)
    finally show "d  poly_deg p" .
  qed
  finally show ?thesis by simp
qed

lemma subst_pp_cong: "s = t  (x. x  keys t  f x = g x)  subst_pp f s = subst_pp g t"
  by (simp add: subst_pp_def)

lemma poly_subst_cong:
  assumes "p = q" and "x. x  indets q  f x = g x"
  shows "poly_subst f p = poly_subst g q"
proof (simp add: poly_subst_def assms(1), rule sum.cong)
  fix t
  assume "t  keys q"
  {
    fix x
    assume "x  keys t"
    with t  keys q have "x  indets q" by (auto simp: indets_def)
    hence "f x = g x" by (rule assms(2))
  }
  thus "punit.monom_mult (lookup q t) 0 (subst_pp f t) = punit.monom_mult (lookup q t) 0 (subst_pp g t)"
    by (simp cong: subst_pp_cong)
qed (fact refl)

lemma Polys_homomorphismE:
  obtains h where "p q. h (p + q) = h p + h q" and "p q. h (p * q) = h p * h q"
    and "p::('x 0 nat) 0 'a::comm_ring_1. h (h p) = h p" and "range h = P[X]"
proof -
  let ?f = "λx. if x  X then monomial (1::'a) (Poly_Mapping.single x 1) else 1"

  have 1: "poly_subst ?f p = p" if "p  P[X]" for p
  proof (rule poly_subst_id)
    fix x
    assume "x  indets p"
    also from that have "  X" by (rule PolysD)
    finally show "?f x = monomial 1 (Poly_Mapping.single x 1)" by simp
  qed

  have 2: "poly_subst ?f p  P[X]" for p
  proof (intro PolysI_alt subsetI)
    fix x
    assume "x  indets (poly_subst ?f p)"
    then obtain y where "x  indets (?f y)" by (rule in_indets_poly_substE)
    thus "x  X" by (simp add: indets_monomial split: if_split_asm)
  qed

  from poly_subst_plus poly_subst_times show ?thesis
  proof
    fix p
    from 2 show "poly_subst ?f (poly_subst ?f p) = poly_subst ?f p" by (rule 1)
  next
    show "range (poly_subst ?f) = P[X]"
    proof (intro set_eqI iffI)
      fix p :: "_ 0 'a"
      assume "p  P[X]"
      hence "p = poly_subst ?f p" by (simp only: 1)
      thus "p  range (poly_subst ?f)" by (rule image_eqI) simp
    qed (auto intro: 2)
  qed
qed

lemma in_idealE_Polys_finite:
  assumes "finite B" and "B  P[X]" and "p  P[X]" and "(p::('x 0 nat) 0 'a::comm_ring_1)  ideal B"
  obtains q where "b. q b  P[X]" and "p = (bB. q b * b)"
proof -
  obtain h where "p q. h (p + q) = h p + h q" and "p q. h (p * q) = h p * h q"
    and "p::('x 0 nat) 0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
    by (rule Polys_homomorphismE) blast
  from this(1-3) assms obtain q where "b. q b  P[X]" and "p = (bB. q b * b)"
    unfolding rng by (rule in_idealE_homomorphism_finite) blast
  thus ?thesis ..
qed

corollary in_idealE_Polys:
  assumes "B  P[X]" and "p  P[X]" and "p  ideal B"
  obtains A q where "finite A" and "A  B" and "b. q b  P[X]" and "p = (bA. q b * b)"
proof -
  from assms(3) obtain A where "finite A" and "A  B" and "p  ideal A"
    by (rule ideal.span_finite_subset)
  from this(2) assms(1) have "A  P[X]" by (rule subset_trans)
  with ‹finite A obtain q where "b. q b  P[X]" and "p = (bA. q b * b)"
    using assms(2) p  ideal A by (rule in_idealE_Polys_finite) blast
  with ‹finite A A  B show ?thesis ..
qed

lemma ideal_induct_Polys [consumes 3, case_names 0 plus]:
  assumes "F  P[X]" and "p  P[X]" and "p  ideal F"
  assumes "P 0" and "c q h. c  P[X]  q  F  P h  h  P[X]  P (c * q + h)"
  shows "P (p::('x 0 nat) 0 'a::comm_ring_1)"
proof -
  obtain h where "p q. h (p + q) = h p + h q" and "p q. h (p * q) = h p * h q"
    and "p::('x 0 nat) 0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
    by (rule Polys_homomorphismE) blast
  from this(1-3) assms show ?thesis
    unfolding rng by (rule ideal_induct_homomorphism) blast
qed

lemma image_poly_subst_ideal_subset: "poly_subst g ` ideal F  ideal (poly_subst g ` F)"
proof (intro subsetI, elim imageE)
  fix h f
  assume h: "h = poly_subst g f"
  assume "f  ideal F"
  thus "h  ideal (poly_subst g ` F)" unfolding h
  proof (induct f rule: ideal.span_induct_alt)
    case base
    show ?case by (simp add: ideal.span_zero)
  next
    case (step c f h)
    from step.hyps(1) have "poly_subst g f  ideal (poly_subst g ` F)"
      by (intro ideal.span_base imageI)
    hence "poly_subst g c * poly_subst g f  ideal (poly_subst g ` F)" by (rule ideal.span_scale)
    hence "poly_subst g c * poly_subst g f + poly_subst g h  ideal (poly_subst g ` F)"
      using step.hyps(2) by (rule ideal.span_add)
    thus ?case by (simp only: poly_subst_plus poly_subst_times)
  qed
qed

subsection ‹Evaluating Polynomials›

lemma lookup_times_zero:
  "lookup (p * q) 0 = lookup p 0 * lookup q (0::'a::{comm_powerprod,ninv_comm_monoid_add})"
proof -
  have eq: "(vkeys q. lookup q v when t + v = 0) = (lookup q 0 when t = 0)" for t
  proof -
    have "(vkeys q. lookup q v when t + v = 0) = (vkeys q  {0}. lookup q v when t + v = 0)"
    proof (intro sum.mono_neutral_right ballI)
      fix v
      assume "v  keys q - keys q  {0}"
      hence "v  0" by blast
      hence "t + v  0" using plus_eq_zero_2 by blast
      thus "(lookup q v when t + v = 0) = 0" by simp
    qed simp_all
    also have " = (lookup q 0 when t = 0)" by (cases "0  keys q") (simp_all add: in_keys_iff)
    finally show ?thesis .
  qed
  have "(tkeys p. lookup p t * lookup q 0 when t = 0) =
          (tkeys p  {0}. lookup p t * lookup q 0 when t = 0)"
  proof (intro sum.mono_neutral_right ballI)
    fix t
    assume "t  keys p - keys p  {0}"
    hence "t  0" by blast
    thus "(lookup p t * lookup q 0 when t = 0) = 0" by simp
  qed simp_all
  also have " = lookup p 0 * lookup q 0" by (cases "0  keys p") (simp_all add: in_keys_iff)
  finally show ?thesis by (simp add: lookup_times eq when_distrib)
qed

corollary lookup_prod_zero:
  "lookup (prod f I) 0 = (iI. lookup (f i) (0::_::{comm_powerprod,ninv_comm_monoid_add}))"
  by (induct I rule: infinite_finite_induct) (simp_all add: lookup_times_zero)

corollary lookup_power_zero:
  "lookup (p ^ k) 0 = lookup p (0::_::{comm_powerprod,ninv_comm_monoid_add}) ^ k"
  by (induct k) (simp_all add: lookup_times_zero)

definition poly_eval :: "('x  'a)  (('x 0 nat) 0 'a)  'a::comm_semiring_1"
  where "poly_eval a p = lookup (poly_subst (λy. monomial (a y) (0::'x 0 nat)) p) 0"

lemma poly_eval_alt: "poly_eval a p = (tkeys p. lookup p t * (xkeys t. a x ^ lookup t x))"
  by (simp add: poly_eval_def poly_subst_def lookup_sum lookup_times_zero subst_pp_def
          lookup_prod_zero lookup_power_zero flip: times_monomial_left)

lemma poly_eval_monomial: "poly_eval a (monomial c t) = c * (xkeys t. a x ^ lookup t x)"
  by (simp add: poly_eval_def poly_subst_monomial subst_pp_def punit.lookup_monom_mult
      lookup_prod_zero lookup_power_zero)

lemma poly_eval_zero [simp]: "poly_eval a 0 = 0"
  by (simp only: poly_eval_def poly_subst_zero lookup_zero)

lemma poly_eval_zero_left [simp]: "poly_eval 0 p = lookup p 0"
  by (simp add: poly_eval_def)

lemma poly_eval_plus: "poly_eval a (p + q) = poly_eval a p + poly_eval a q"
  by (simp only: poly_eval_def poly_subst_plus lookup_add)

lemma poly_eval_uminus [simp]: "poly_eval a (- p) = - poly_eval (a::_::comm_ring_1) p"
  by (simp only: poly_eval_def poly_subst_uminus lookup_uminus)

lemma poly_eval_minus: "poly_eval a (p - q) = poly_eval a p - poly_eval (a::_::comm_ring_1) q"
  by (simp only: poly_eval_def poly_subst_minus lookup_minus)

lemma poly_eval_one [simp]: "poly_eval a 1 = 1"
  by (simp add: poly_eval_def lookup_one)

lemma poly_eval_times: "poly_eval a (p * q) = poly_eval a p * poly_eval a q"
  by (simp only: poly_eval_def poly_subst_times lookup_times_zero)

lemma poly_eval_power: "poly_eval a (p ^ m) = poly_eval a p ^ m"
  by (induct m) (simp_all add: poly_eval_times)

lemma poly_eval_sum: "poly_eval a (sum f I) = (iI. poly_eval a (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_plus)

lemma poly_eval_prod: "poly_eval a (prod f I) = (iI. poly_eval a (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_times)

lemma poly_eval_cong: "p = q  (x. x  indets q  a x = b x)  poly_eval a p = poly_eval b q"
  by (simp add: poly_eval_def cong: poly_subst_cong)

lemma indets_poly_eval_subset:
  "indets (poly_eval a p)   (indets ` a ` indets p)   (indets ` lookup p ` keys p)"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by simp
next
  case (2 p c t)
  have "keys (monomial c t + p) = keys (monomial c t)  keys p"
    by (rule keys_plus_eqI) (simp add: 2(2))
  with 2(1) have eq1: "keys (monomial c t + p) = insert t (keys p)" by simp
  hence eq2: "indets (monomial c t + p) = keys t  indets p" by (simp add: indets_def)
  from 2(2) have eq3: "lookup (monomial c t + p) t = c" by (simp add: lookup_add in_keys_iff)
  have eq4: "lookup (monomial c t + p) s = lookup p s" if "s  keys p" for s
    using that 2(2) by (auto simp: lookup_add lookup_single when_def)
  have "indets (poly_eval a (monomial c t + p)) =
          indets (c * (xkeys t. a x ^ lookup t x) + poly_eval a p)"
    by (simp only: poly_eval_plus poly_eval_monomial)
  also have "  indets (c * (xkeys t. a x ^ lookup t x))  indets (poly_eval a p)"
    by (fact indets_plus_subset)
  also have "  indets c  ( (indets ` a ` keys t)) 
                    ( (indets ` a ` indets p)   (indets ` lookup p ` keys p))"
  proof (intro Un_mono 2(3))
    have "indets (c * (xkeys t. a x ^ lookup t x))  indets c  indets (xkeys t. a x ^ lookup t x)"
      by (fact indets_times_subset)
    also have "indets (xkeys t. a x ^ lookup t x)  (xkeys t. indets (a x ^ lookup t x))"
      by (fact indets_prod_subset)
    also have "  (xkeys t. indets (a x))" by (intro UN_mono subset_refl indets_power_subset)
    also have " =  (indets ` a ` keys t)" by simp
    finally show "indets (c * (xkeys t. a x ^ lookup t x))  indets c   (indets ` a ` keys t)"
      by blast
  qed
  also have " =  (indets ` a ` indets (monomial c t + p)) 
                     (indets ` lookup (monomial c t + p) ` keys (monomial c t + p))"
    by (simp add: eq1 eq2 eq3 eq4 Un_commute Un_assoc Un_left_commute)
  finally show ?case .
qed

lemma image_poly_eval_ideal: "poly_eval a ` ideal F = ideal (poly_eval a ` F)"
proof (intro image_ideal_eq_surj poly_eval_plus poly_eval_times surjI)
  fix x
  show "poly_eval a (monomial x 0) = x" by (simp add: poly_eval_monomial)
qed

subsection ‹Replacing Indeterminates›

definition map_indets where "map_indets f = poly_subst (λx. monomial 1 (Poly_Mapping.single (f x) 1))"

lemma
  shows map_indets_zero [simp]: "map_indets f 0 = 0"
    and map_indets_one [simp]: "map_indets f 1 = 1"
    and map_indets_uminus [simp]: "map_indets f (- r) = - map_indets f (r::_ 0 _::comm_ring_1)"
    and map_indets_plus: "map_indets f (p + q) = map_indets f p + map_indets f q"
    and map_indets_minus: "map_indets f (r - s) = map_indets f r - map_indets f s"
    and map_indets_times: "map_indets f (p * q) = map_indets f p * map_indets f q"
    and map_indets_power [simp]: "map_indets f (p ^ m) = map_indets f p ^ m"
    and map_indets_sum: "map_indets f (sum g A) = (aA. map_indets f (g a))"
    and map_indets_prod: "map_indets f (prod g A) = (aA. map_indets f (g a))"
  by (simp_all add: map_indets_def poly_subst_uminus poly_subst_plus poly_subst_minus poly_subst_times
      poly_subst_power poly_subst_sum poly_subst_prod)

lemma map_indets_monomial:
  "map_indets f (monomial c t) = monomial c (xkeys t. Poly_Mapping.single (f x) (lookup t x))"
  by (simp add: map_indets_def poly_subst_monomial subst_pp_def monomial_power_map_scale
      punit.monom_mult_monomial flip: punit.monomial_prod_sum)

lemma map_indets_id: "(x. x  indets p  f x = x)  map_indets f p = p"
  by (simp add: map_indets_def poly_subst_id)

lemma map_indets_map_indets: "map_indets f (map_indets g p) = map_indets (f  g) p"
  by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single)

lemma map_indets_cong: "p = q  (x. x  indets q  f x = g x)  map_indets f p = map_indets g q"
  unfolding map_indets_def by (simp cong: poly_subst_cong)

lemma poly_subst_map_indets: "poly_subst f (map_indets g p) = poly_subst (f  g) p"
  by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single comp_def)

lemma poly_eval_map_indets: "poly_eval a (map_indets g p) = poly_eval (a  g) p"
  by (simp add: poly_eval_def poly_subst_map_indets comp_def)
      (simp add: poly_subst_def lookup_sum lookup_times_zero subst_pp_def lookup_prod_zero
          lookup_power_zero flip: times_monomial_left)

lemma map_indets_inverseE_Polys:
  assumes "inj_on f X" and "p  P[X]"
  shows "map_indets (the_inv_into X f) (map_indets f p) = p"
  unfolding map_indets_map_indets
proof (rule map_indets_id)
  fix x
  assume "x  indets p"
  also from assms(2) have "  X" by (rule PolysD)
  finally show "(the_inv_into X f  f) x = x" using assms(1) by (auto intro: the_inv_into_f_f)
qed

lemma map_indets_inverseE:
  assumes "inj f"
  obtains g where "g = the_inv f" and "g  f = id" and "map_indets g  map_indets f = id"
proof -
  define g where "g = the_inv f"
  moreover from assms have eq: "g  f = id" by (auto intro!: ext the_inv_f_f simp: g_def)
  moreover have "map_indets g  map_indets f = id"
    by (rule ext) (simp add: map_indets_map_indets eq map_indets_id)
  ultimately show ?thesis ..
qed

lemma indets_map_indets_subset: "indets (map_indets f (p::_ 0 'a::comm_semiring_1))  f ` indets p"
proof
  fix x
  assume "x  indets (map_indets f p)"
  then obtain y where "y  indets p" and "x  indets (monomial (1::'a) (Poly_Mapping.single (f y) 1))"
    unfolding map_indets_def by (rule in_indets_poly_substE)
  from this(2) have x: "x = f y" by (simp add: indets_monomial)
  from y  indets p show "x  f ` indets p" unfolding x by (rule imageI)
qed

corollary map_indets_in_Polys: "map_indets f p  P[f ` indets p]"
  using indets_map_indets_subset by (rule PolysI_alt)

lemma indets_map_indets:
  assumes "inj_on f (indets p)"
  shows "indets (map_indets f p) = f ` indets p"
  using indets_map_indets_subset
proof (rule subset_antisym)
  let ?g = "the_inv_into (indets p) f"
  have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
    by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
  also have "indets   ?g ` indets (map_indets f p)" by (fact indets_map_indets_subset)
  finally have "f ` indets p  f ` ?g ` indets (map_indets f p)" by (rule image_mono)
  also have " = (λx. x) ` indets (map_indets f p)" unfolding image_image using refl
  proof (rule image_cong)
    fix x
    assume "x  indets (map_indets f p)"
    with indets_map_indets_subset have "x  f ` indets p" ..
    with assms show "f (?g x) = x" by (rule f_the_inv_into_f)
  qed
  finally show "f ` indets p  indets (map_indets f p)" by simp
qed

lemma image_map_indets_Polys: "map_indets f ` P[X] = (P[f ` X]::(_ 0 'a::comm_semiring_1) set)"
proof (intro set_eqI iffI)
  fix p :: "_ 0 'a"
  assume "p  map_indets f ` P[X]"
  then obtain q where "q  P[X]" and "p = map_indets f q" ..
  note this(2)
  also have "map_indets f q  P[f ` indets q]" by (fact map_indets_in_Polys)
  also from q  _ have "  P[f ` X]" by (auto intro!: Polys_mono imageI dest: PolysD)
  finally show "p  P[f ` X]" .
next
  fix p :: "_ 0 'a"
  assume "p  P[f ` X]"
  define g where "g = (λy. SOME x. x  X  f x = y)"
  have "g y  X  f (g y) = y" if "y  indets p" for y
  proof -
    note that
    also from p  _ have "indets p  f ` X" by (rule PolysD)
    finally obtain x where "x  X" and "y = f x" ..
    hence "x  X  f x = y" by simp
    thus ?thesis unfolding g_def by (rule someI)
  qed
  hence 1: "g y  X" and 2: "f (g y) = y" if "y  indets p" for y using that by simp_all
  show "p  map_indets f ` P[X]"
  proof
    show "p = map_indets f (map_indets g p)"
      by (rule sym) (simp add: map_indets_map_indets map_indets_id 2)
  next
    have "map_indets g p  P[g ` indets p]" by (fact map_indets_in_Polys)
    also have "  P[X]" by (auto intro!: Polys_mono 1)
    finally show "map_indets g p  P[X]" .
  qed
qed

corollary range_map_indets: "range (map_indets f) = P[range f]"
proof -
  have "range (map_indets f) = map_indets f ` P[UNIV]" by simp
  also have " = P[range f]" by (simp only: image_map_indets_Polys)
  finally show ?thesis .
qed

lemma in_keys_map_indetsE:
  assumes "t  keys (map_indets f (p::_ 0 'a::comm_semiring_1))"
  obtains s where "s  keys p" and "t = (xkeys s. Poly_Mapping.single (f x) (lookup s x))"
proof -
  let ?f = "(λx. monomial (1::'a) (Poly_Mapping.single (f x) 1))"
  from assms obtain s where "s  keys p" and "t  keys (subst_pp ?f s)" unfolding map_indets_def
    by (rule in_keys_poly_substE)
  note this(2)
  also have "  {xkeys s. Poly_Mapping.single (f x) (lookup s x)}"
    by (simp add: subst_pp_def monomial_power_map_scale flip: punit.monomial_prod_sum)
  finally have "t = (xkeys s. Poly_Mapping.single (f x) (lookup s x))" by simp
  with s  keys p show ?thesis ..
qed

lemma keys_map_indets_subset:
  "keys (map_indets f p)  (λt. xkeys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
  by (auto elim: in_keys_map_indetsE)

lemma keys_map_indets:
  assumes "inj_on f (indets p)"
  shows "keys (map_indets f p) = (λt. xkeys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
  using keys_map_indets_subset
proof (rule subset_antisym)
  let ?g = "the_inv_into (indets p) f"
  have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
    by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
  also have "keys   (λt. xkeys t. monomial (lookup t x) (?g x)) ` keys (map_indets f p)"
    by (rule keys_map_indets_subset)
  finally have "(λt. xkeys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p 
                (λt. xkeys t. Poly_Mapping.single (f x) (lookup t x)) `
                (λt. xkeys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
    by (rule image_mono)
  also from refl have " = (λt. x. Poly_Mapping.single (f x) (lookup t x)) `
                       (λt. xkeys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
    by (rule image_cong)
        (smt Sum_any.conditionalize Sum_any.cong finite_keys not_in_keys_iff_lookup_eq_zero single_zero)
  also have " = (λt. t) ` keys (map_indets f p)" unfolding image_image using refl
  proof (rule image_cong)
    fix t
    assume "t  keys (map_indets f p)"
    have "(x. monomial (lookup (ykeys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) =
          (x. ykeys t. monomial (lookup t y when ?g y = x) (f x))"
      by (simp add: lookup_sum lookup_single monomial_sum)
    also have " = (xindets p. ykeys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
    proof (intro Sum_any.expand_superset finite_indets subsetI)
      fix x
      assume "x  {a. (ykeys t. Poly_Mapping.single (f a) (lookup t y when ?g y = a))  0}"
      hence "(ykeys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x))  0" by simp
      then obtain y where "y  keys t" and *: "Poly_Mapping.single (f x) (lookup t y when ?g y = x)  0"
        by (rule sum.not_neutral_contains_not_neutral)
      from this(1) have "y  indets (map_indets f p)" using t  _ by (rule in_indetsI)
      with indets_map_indets_subset have "y  f ` indets p" ..
      from * have "x = ?g y" by (simp add: when_def split: if_split_asm)
      also from assms y  f ` indets p subset_refl have "  indets p" by (rule the_inv_into_into)
      finally show "x  indets p" .
    qed
    also have " = (ykeys t. xindets p. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
      by (fact sum.swap)
    also from refl have " = (ykeys t. Poly_Mapping.single y (lookup t y))"
    proof (rule sum.cong)
      fix x
      assume "x  keys t"
      hence "x  indets (map_indets f p)" using t  _ by (rule in_indetsI)
      with indets_map_indets_subset have "x  f ` indets p" ..
      with assms have "?g x  indets p" using subset_refl by (rule the_inv_into_into)
      hence "{?g x}  indets p" by simp
      with finite_indets have "(yindets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
                                (y{?g x}. Poly_Mapping.single (f y) (lookup t x when ?g x = y))"
        by (rule sum.mono_neutral_right) (simp add: monomial_0_iff when_def)
      also from assms x  f ` indets p have " = Poly_Mapping.single x (lookup t x)"
        by (simp add: f_the_inv_into_f)
      finally show "(yindets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
                      Poly_Mapping.single x (lookup t x)" .
    qed
    also have " = t" by (fact poly_mapping_sum_monomials)
    finally show "(x. monomial (lookup (ykeys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) = t" .
  qed
  also have " = keys (map_indets f p)" by simp
  finally show "(λt. xkeys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p  keys (map_indets f p)" .
qed

lemma poly_deg_map_indets_le: "poly_deg (map_indets f p)  poly_deg p"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (map_indets f p)"
  then obtain s where "s  keys p" and t: "t = (xkeys s. Poly_Mapping.single (f x) (lookup s x))"
    by (rule in_keys_map_indetsE)
  from this(1) have "deg_pm s  poly_deg p" by (rule poly_deg_max_keys)
  thus "deg_pm t  poly_deg p"
    by (simp add: t deg_pm_sum deg_pm_single deg_pm_superset[OF subset_refl])
qed

lemma poly_deg_map_indets:
  assumes "inj_on f (indets p)"
  shows "poly_deg (map_indets f p) = poly_deg p"
proof -
  from assms have "deg_pm ` keys (map_indets f p) = deg_pm ` keys p"
    by (simp add: keys_map_indets image_image deg_pm_sum deg_pm_single
          flip: deg_pm_superset[OF subset_refl])
  thus ?thesis by (auto simp: poly_deg_def)
qed

lemma map_indets_inj_on_PolysI:
  assumes "inj_on (f::'x  'y) X"
  shows "inj_on ((map_indets f)::_  _ 0 'a::comm_semiring_1) P[X]"
proof (rule inj_onI)
  fix p q :: "_ 0 'a"
  assume "p  P[X]"
  with assms have 1: "map_indets (the_inv_into X f) (map_indets f p) = p" (is "map_indets ?g _ = _")
    by (rule map_indets_inverseE_Polys)
  assume "q  P[X]"
  with assms have "map_indets ?g (map_indets f q) = q" by (rule map_indets_inverseE_Polys)
  moreover assume "map_indets f p = map_indets f q"
  ultimately show "p = q" using 1 by (simp add: map_indets_map_indets)
qed

lemma map_indets_injI:
  assumes "inj f"
  shows "inj (map_indets f)"
proof -
  from assms have "inj_on (map_indets f) P[UNIV]" by (rule map_indets_inj_on_PolysI)
  thus ?thesis by simp
qed

lemma image_map_indets_ideal:
  assumes "inj f"
  shows "map_indets f ` ideal F = ideal (map_indets f ` (F::(_ 0 'a::comm_ring_1) set))  P[range f]"
proof
  from map_indets_plus map_indets_times have "map_indets f ` ideal F  ideal (map_indets f ` F)"
    by (rule image_ideal_subset)
  moreover from subset_UNIV have "map_indets f ` ideal F  range (map_indets f)" by (rule image_mono)
  ultimately show "map_indets f ` ideal F  ideal (map_indets f ` F)  P[range f]"
    unfolding range_map_indets by blast
next
  show "ideal (map_indets f ` F)  P[range f]  map_indets f ` ideal F"
  proof
    fix p
    assume "p  ideal (map_indets f ` F)  P[range f]"
    hence "p  ideal (map_indets f ` F)" and "p  range (map_indets f)"
      by (simp_all add: range_map_indets)
    from this(1) obtain F0 q where "F0  map_indets f ` F" and p: "p = (f'F0. q f' * f')"
      by (rule ideal.spanE)
    from this(1) obtain F' where "F'  F" and F0: "F0 = map_indets f ` F'" by (rule subset_imageE)
    from assms obtain g where "map_indets g  map_indets f = (id::_  _ 0 'a)"
      by (rule map_indets_inverseE)
    hence eq: "map_indets g (map_indets f p') = p'" for p'::"_ 0 'a"
      by (simp add: pointfree_idE)
    from assms have "inj (map_indets f)" by (rule map_indets_injI)
    from this subset_UNIV have "inj_on (map_indets f) F'" by (rule inj_on_subset)
    from p  range _ obtain p' where "p = map_indets f p'" ..
    hence "p = map_indets f (map_indets g p)" by (simp add: eq)
    also from ‹inj_on _ F' have " = map_indets f (f'F'. map_indets g (q (map_indets f f')) * f')"
      by (simp add: p F0 sum.reindex map_indets_sum map_indets_times eq)
    finally have "p = map_indets f (f'F'. map_indets g (q (map_indets f f')) * f')" .
    moreover have "(f'F'. map_indets g (q (map_indets f f')) * f')  ideal F"
    proof
      show "(f'F'. map_indets g (q (map_indets f f')) * f')  ideal F'" by (rule ideal.sum_in_spanI)
    next
      from F'  F show "ideal F'  ideal F" by (rule ideal.span_mono)
    qed
    ultimately show "p  map_indets f ` ideal F" by (rule image_eqI)
  qed
qed

subsection ‹Homogeneity›

definition homogeneous :: "(('x 0 nat) 0 'a::zero)  bool"
  where "homogeneous p  (skeys p. tkeys p. deg_pm s = deg_pm t)"

definition hom_component :: "(('x 0 nat) 0 'a)  nat  (('x 0 nat) 0 'a::zero)"
  where "hom_component p n = except p {t. deg_pm t  n}"

definition hom_components :: "(('x 0 nat) 0 'a)  (('x 0 nat) 0 'a::zero) set"
  where "hom_components p = hom_component p ` deg_pm ` keys p"

definition homogeneous_set :: "(('x 0 nat) 0 'a::zero) set  bool"
  where "homogeneous_set A  (aA. n. hom_component a n  A)"

lemma homogeneousI: "(s t. s  keys p  t  keys p  deg_pm s = deg_pm t)  homogeneous p"
  unfolding homogeneous_def by blast

lemma homogeneousD: "homogeneous p  s  keys p  t  keys p  deg_pm s = deg_pm t"
  unfolding homogeneous_def by blast

lemma homogeneousD_poly_deg:
  assumes "homogeneous p" and "t  keys p"
  shows "deg_pm t = poly_deg p"
proof (rule antisym)
  from assms(2) show "deg_pm t  poly_deg p" by (rule poly_deg_max_keys)
next
  show "poly_deg p  deg_pm t"
  proof (rule poly_deg_leI)
    fix s
    assume "s  keys p"
    with assms(1) have "deg_pm s = deg_pm t" using assms(2) by (rule homogeneousD)
    thus "deg_pm s  deg_pm t" by simp
  qed
qed

lemma homogeneous_monomial [simp]: "homogeneous (monomial c t)"
  by (auto split: if_split_asm intro: homogeneousI)

corollary homogeneous_zero [simp]: "homogeneous 0" and homogeneous_one [simp]: "homogeneous 1"
  by (simp_all only: homogeneous_monomial flip: single_zero[of 0] single_one)

lemma homogeneous_uminus_iff [simp]: "homogeneous (- p)  homogeneous p"
  by (auto intro!: homogeneousI dest: homogeneousD simp: keys_uminus)

lemma homogeneous_monom_mult: "homogeneous p  homogeneous (punit.monom_mult c t p)"
  by (auto intro!: homogeneousI elim!: punit.keys_monom_multE simp: deg_pm_plus dest: homogeneousD)

lemma homogeneous_monom_mult_rev:
  assumes "c  (0::'a::semiring_no_zero_divisors)" and "homogeneous (punit.monom_mult c t p)"
  shows "homogeneous p"
proof (rule homogeneousI)
  fix s s'
  assume "s  keys p"
  hence 1: "t + s  keys (punit.monom_mult c t p)"
    using assms(1) by (rule punit.keys_monom_multI[simplified])
  assume "s'  keys p"
  hence "t + s'  keys (punit.monom_mult c t p)"
    using assms(1) by (rule punit.keys_monom_multI[simplified])
  with assms(2) 1 have "deg_pm (t + s) = deg_pm (t + s')" by (rule homogeneousD)
  thus "deg_pm s = deg_pm s'" by (simp add: deg_pm_plus)
qed

lemma homogeneous_times:
  assumes "homogeneous p" and "homogeneous q"
  shows "homogeneous (p * q)"
proof (rule homogeneousI)
  fix s t
  assume "s  keys (p * q)"
  then obtain sp sq where sp: "sp  keys p" and sq: "sq  keys q" and s: "s = sp + sq"
    by (rule in_keys_timesE)
  assume "t  keys (p * q)"
  then obtain tp tq where tp: "tp  keys p" and tq: "tq  keys q" and t: "t = tp + tq"
    by (rule in_keys_timesE)
  from assms(1) sp tp have "deg_pm sp = deg_pm tp" by (rule homogeneousD)
  moreover from assms(2) sq tq have "deg_pm sq = deg_pm tq" by (rule homogeneousD)
  ultimately show "deg_pm s = deg_pm t" by (simp only: s t deg_pm_plus)
qed

lemma lookup_hom_component: "lookup (hom_component p n) = (λt. lookup p t when deg_pm t = n)"
  by (rule ext) (simp add: hom_component_def lookup_except)

lemma keys_hom_component: "keys (hom_component p n) = {t. t  keys p  deg_pm t = n}"
  by (auto simp: hom_component_def keys_except)

lemma keys_hom_componentD:
  assumes "t  keys (hom_component p n)"
  shows "t  keys p" and "deg_pm t = n"
  using assms by (simp_all add: keys_hom_component)

lemma homogeneous_hom_component: "homogeneous (hom_component p n)"
  by (auto dest: keys_hom_componentD intro: homogeneousI)

lemma hom_component_zero [simp]: "hom_component 0 = 0"
  by (rule ext) (simp add: hom_component_def)

lemma hom_component_zero_iff: "hom_component p n = 0  (tkeys p. deg_pm t  n)"
  by (metis (mono_tags, lifting) empty_iff keys_eq_empty_iff keys_hom_component mem_Collect_eq subsetI subset_antisym)

lemma hom_component_uminus [simp]: "hom_component (- p) = - hom_component p"
  by (intro ext poly_mapping_eqI) (simp add: hom_component_def lookup_except)

lemma hom_component_plus: "hom_component (p + q) n = hom_component p n + hom_component q n"
  by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_add)

lemma hom_component_minus: "hom_component (p - q) n = hom_component p n - hom_component q n"
  by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_minus)

lemma hom_component_monom_mult:
  "punit.monom_mult c t (hom_component p n) = hom_component (punit.monom_mult c t p) (deg_pm t + n)"
  by (auto simp: hom_component_def lookup_except punit.lookup_monom_mult deg_pm_minus deg_pm_mono intro!: poly_mapping_eqI)

lemma hom_component_inject:
  assumes "t  keys p" and "hom_component p (deg_pm t) = hom_component p n"
  shows "deg_pm t = n"
proof -
  from assms(1) have "t  keys (hom_component p (deg_pm t))" by (simp add: keys_hom_component)
  hence "0  lookup (hom_component p (deg_pm t)) t" by (simp add: in_keys_iff)
  also have "lookup (hom_component p (deg_pm t)) t = lookup (hom_component p n) t"
    by (simp only: assms(2))
  also have " = (lookup p t when deg_pm t = n)" by (simp only: lookup_hom_component)
  finally show ?thesis by simp
qed

lemma hom_component_of_homogeneous:
  assumes "homogeneous p"
  shows "hom_component p n = (p when n = poly_deg p)"
proof (cases "n = poly_deg p")
  case True
  have "hom_component p n = p"
  proof (rule poly_mapping_eqI)
    fix t
    show "lookup (hom_component p n) t = lookup p t"
    proof (cases "t  keys p")
      case True
      with assms have "deg_pm t = n" unfolding n = poly_deg p by (rule homogeneousD_poly_deg)
      thus ?thesis by (simp add: lookup_hom_component)
    next
      case False
      moreover from this have "t  keys (hom_component p n)" by (simp add: keys_hom_component)
      ultimately show ?thesis by (simp add: in_keys_iff)
    qed
  qed
  with True show ?thesis by simp
next
  case False
  have "hom_component p n = 0" unfolding hom_component_zero_iff
  proof (intro ballI notI)
    fix t
    assume "t  keys p"
    with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
    moreover assume "deg_pm t = n"
    ultimately show False using False by simp
  qed
  with False show ?thesis by simp
qed

lemma hom_components_zero [simp]: "hom_components 0 = {}"
  by (simp add: hom_components_def)

lemma hom_components_zero_iff [simp]: "hom_components p = {}  p = 0"
  by (simp add: hom_components_def)

lemma hom_components_uminus: "hom_components (- p) = uminus ` hom_components p"
  by (simp add: hom_components_def keys_uminus image_image)

lemma hom_components_monom_mult:
  "hom_components (punit.monom_mult c t p) = (if c = 0 then {} else punit.monom_mult c t ` hom_components p)"
  for c::"'a::semiring_no_zero_divisors"
  by (simp add: hom_components_def punit.keys_monom_mult image_image deg_pm_plus hom_component_monom_mult)

lemma hom_componentsI: "q = hom_component p (deg_pm t)  t  keys p  q  hom_components p"
  unfolding hom_components_def by blast

lemma hom_componentsE:
  assumes "q  hom_components p"
  obtains t where "t  keys p" and "q = hom_component p (deg_pm t)"
  using assms unfolding hom_components_def by blast

lemma hom_components_of_homogeneous:
  assumes "homogeneous p"
  shows "hom_components p = (if p = 0 then {} else {p})"
proof (split if_split, intro conjI impI)
  assume "p  0"
  have "deg_pm ` keys p = {poly_deg p}"
  proof (rule set_eqI)
    fix n
    have "n  deg_pm ` keys p  n = poly_deg p"
    proof
      assume "n  deg_pm ` keys p"
      then obtain t where "t  keys p" and "n = deg_pm t" ..
      from assms this(1) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
      thus "n = poly_deg p" by (simp only: n = deg_pm t)
    next
      assume "n = poly_deg p"
      from p  0 have "keys p  {}" by simp
      then obtain t where "t  keys p" by blast
      with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
      hence "n = deg_pm t" by (simp only: n = poly_deg p)
      with t  keys p show "n  deg_pm ` keys p" by (rule rev_image_eqI)
    qed
    thus "n  deg_pm ` keys p  n  {poly_deg p}" by simp
  qed
  with assms show "hom_components p = {p}"
    by (simp add: hom_components_def hom_component_of_homogeneous)
qed simp

lemma finite_hom_components: "finite (hom_components p)"
  unfolding hom_components_def using finite_keys by (intro finite_imageI)

lemma hom_components_homogeneous: "q  hom_components p  homogeneous q"
  by (elim hom_componentsE) (simp only: homogeneous_hom_component)

lemma hom_components_nonzero: "q  hom_components p  q  0"
  by (auto elim!: hom_componentsE simp: hom_component_zero_iff)

lemma deg_pm_hom_components:
  assumes "q1  hom_components p" and "q2  hom_components p" and "t1  keys q1" and "t2  keys q2"
  shows "deg_pm t1 = deg_pm t2  q1 = q2"
proof -
  from assms(1) obtain s1 where "s1  keys p" and q1: "q1 = hom_component p (deg_pm s1)"
    by (rule hom_componentsE)
  from assms(3) have t1: "deg_pm t1 = deg_pm s1" unfolding q1 by (rule keys_hom_componentD)
  from assms(2) obtain s2 where "s2  keys p" and q2: "q2 = hom_component p (deg_pm s2)"
    by (rule hom_componentsE)
  from assms(4) have t2: "deg_pm t2 = deg_pm s2" unfolding q2 by (rule keys_hom_componentD)
  from s1  keys p show ?thesis by (auto simp: q1 q2 t1 t2 dest: hom_component_inject)
qed

lemma poly_deg_hom_components:
  assumes "q1  hom_components p" and "q2  hom_components p"
  shows "poly_deg q1 = poly_deg q2  q1 = q2"
proof -
  from assms(1) have "homogeneous q1" and "q1  0"
    by (rule hom_components_homogeneous, rule hom_components_nonzero)
  from this(2) have "keys q1  {}" by simp
  then obtain t1 where "t1  keys q1" by blast
  with ‹homogeneous q1 have t1: "deg_pm t1 = poly_deg q1" by (rule homogeneousD_poly_deg)
  from assms(2) have "homogeneous q2" and "q2  0"
    by (rule hom_components_homogeneous, rule hom_components_nonzero)
  from this(2) have "keys q2  {}" by simp
  then obtain t2 where "t2  keys q2" by blast
  with ‹homogeneous q2 have t2: "deg_pm t2 = poly_deg q2" by (rule homogeneousD_poly_deg)
  from assms t1  keys q1 t2  keys q2 have "deg_pm t1 = deg_pm t2  q1 = q2"
    by (rule deg_pm_hom_components)
  thus ?thesis by (simp only: t1 t2)
qed

lemma hom_components_keys_disjoint:
  assumes "q1  hom_components p" and "q2  hom_components p" and "q1  q2"
  shows "keys q1  keys q2 = {}"
proof (rule ccontr)
  assume "keys q1  keys q2  {}"
  then obtain t where "t  keys q1" and "t  keys q2" by blast
  with assms(1, 2) have "deg_pm t = deg_pm t  q1 = q2" by (rule deg_pm_hom_components)
  with assms(3) show False by simp
qed

lemma Keys_hom_components: "Keys (hom_components p) = keys p"
  by (auto simp: Keys_def hom_components_def keys_hom_component)

lemma lookup_hom_components: "q  hom_components p  t  keys q  lookup q t = lookup p t"
  by (auto elim!: hom_componentsE simp: keys_hom_component lookup_hom_component)

lemma poly_deg_hom_components_le:
  assumes "q  hom_components p"
  shows "poly_deg q  poly_deg p"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys q"
  also from assms have "  Keys (hom_components p)" by (rule keys_subset_Keys)
  also have " = keys p" by (fact Keys_hom_components)
  finally show "deg_pm t  poly_deg p" by (rule poly_deg_max_keys)
qed

lemma sum_hom_components: "(hom_components p) = p"
proof (rule poly_mapping_eqI)
  fix t
  show "lookup ((hom_components p)) t = lookup p t" unfolding lookup_sum
  proof (cases "t  keys p")
    case True
    also have "keys p = Keys (hom_components p)" by (simp only: Keys_hom_components)
    finally obtain q where q: "q  hom_components p" and t: "t  keys q" by (rule in_KeysE)
    from this(1) have "(q0hom_components p. lookup q0 t) =
                        (q0insert q (hom_components p). lookup q0 t)"
      by (simp only: insert_absorb)
    also from finite_hom_components have " = lookup q t + (q0hom_components p - {q}. lookup q0 t)"
      by (rule sum.insert_remove)
    also from q t have " = lookup p t + (q0hom_components p - {q}. lookup q0 t)"
      by (simp only: lookup_hom_components)
    also have "(q0hom_components p - {q}. lookup q0 t) = 0"
    proof (intro sum.neutral ballI)
      fix q0
      assume "q0  hom_components p - {q}"
      hence "q0  hom_components p" and "q  q0" by blast+
      with q have "keys q  keys q0 = {}" by (rule hom_components_keys_disjoint)
      with t have "t  keys q0" by blast
      thus "lookup q0 t = 0" by (simp add: in_keys_iff)
    qed
    finally show "(qhom_components p. lookup q t) = lookup p t" by simp
  next
    case False
    hence "t  Keys (hom_components p)" by (simp add: Keys_hom_components)
    hence "qhom_components p. lookup q t = 0" by (simp add: Keys_def in_keys_iff)
    hence "(qhom_components p. lookup q t) = 0" by (rule sum.neutral)
    also from False have " = lookup p t" by (simp add: in_keys_iff)
    finally show "(qhom_components p. lookup q t) = lookup p t" .
  qed
qed

lemma homogeneous_setI: "(a n. a  A  hom_component a n  A)  homogeneous_set A"
  by (simp add: homogeneous_set_def)

lemma homogeneous_setD: "homogeneous_set A  a  A  hom_component a n  A"
  by (simp add: homogeneous_set_def)

lemma homogeneous_set_Polys: "homogeneous_set (P[X]::(_ 0 'a::zero) set)"
proof (intro homogeneous_setI PolysI subsetI)
  fix p::"_ 0 'a" and n t
  assume "p  P[X]"
  assume "t  keys (hom_component p n)"
  hence "t  keys p" by (rule keys_hom_componentD)
  also from p  P[X] have "  .[X]" by (rule PolysD)
  finally show "t  .[X]" .
qed

lemma homogeneous_set_IntI: "homogeneous_set A  homogeneous_set B  homogeneous_set (A  B)"
  by (simp add: homogeneous_set_def)

lemma homogeneous_setD_hom_components:
  assumes "homogeneous_set A" and "a  A" and "b  hom_components a"
  shows "b  A"
proof -
  from assms(3) obtain t::"'a 0 nat" where "b = hom_component a (deg_pm t)"
    by (rule hom_componentsE)
  also from assms(1, 2) have "  A" by (rule homogeneous_setD)
  finally show ?thesis .
qed

lemma zero_in_homogeneous_set:
  assumes "homogeneous_set A" and "A  {}"
  shows "0  A"
proof -
  from assms(2) obtain a where "a  A" by blast
  have "lookup a t = 0" if "deg_pm t = Suc (poly_deg a)" for t
  proof (rule ccontr)
    assume "lookup a t  0"
    hence "t  keys a" by (simp add: in_keys_iff)
    hence "deg_pm t  poly_deg a" by (rule poly_deg_max_keys)
    thus False by (simp add: that)
  qed
  hence "0 = hom_component a (Suc (poly_deg a))"
    by (intro poly_mapping_eqI) (simp add: lookup_hom_component when_def)
  also from assms(1) a  A have "  A" by (rule homogeneous_setD)
  finally show ?thesis .
qed

lemma homogeneous_ideal:
  assumes "f. f  F  homogeneous f" and "p  ideal F"
  shows "hom_component p n  ideal F"
proof -
  from assms(2) have "p  punit.pmdl F" by simp
  thus ?thesis
  proof (induct p rule: punit.pmdl_induct)
    case module_0
    show ?case by (simp add: ideal.span_zero)
  next
    case (module_plus a f c t)
    let ?f = "punit.monom_mult c t f"
    from module_plus.hyps(3) have "f  punit.pmdl F" by (simp add: ideal.span_base)
    hence *: "?f  punit.pmdl F" by (rule punit.pmdl_closed_monom_mult)
    from module_plus.hyps(3) have "homogeneous f" by (rule assms(1))
    hence "homogeneous ?f" by (rule homogeneous_monom_mult)
    hence "hom_component ?f n = (?f when n = poly_deg ?f)" by (rule hom_component_of_homogeneous)
    also from * have "  ideal F" by (simp add: when_def ideal.span_zero)
    finally have "hom_component ?f n  ideal F" .
    with module_plus.hyps(2) show ?case unfolding hom_component_plus by (rule ideal.span_add)
  qed
qed

corollary homogeneous_set_homogeneous_ideal:
  "(f. f  F  homogeneous f)  homogeneous_set (ideal F)"
  by (auto intro: homogeneous_setI homogeneous_ideal)

corollary homogeneous_ideal':
  assumes "f. f  F  homogeneous f" and "p  ideal F" and "q  hom_components p"
  shows "q  ideal F"
  using _ assms(2, 3)
proof (rule homogeneous_setD_hom_components)
  from assms(1) show "homogeneous_set (ideal F)" by (rule homogeneous_set_homogeneous_ideal)
qed

lemma homogeneous_idealE_homogeneous:
  assumes "f. f  F  homogeneous f" and "p  ideal F" and "homogeneous p"
  obtains F' q where "finite F'" and "F'  F" and "p = (fF'. q f * f)" and "f. homogeneous (q f)"
    and "f. f  F'  poly_deg (q f * f) = poly_deg p" and "f. f  F'  q f = 0"
proof -
  from assms(2) obtain F'' q' where "finite F''" and "F''  F" and p: "p = (fF''. q' f * f)"
    by (rule ideal.spanE)
  let ?A = "λf. {h  hom_components (q' f). poly_deg h + poly_deg f = poly_deg p}"
  let ?B = "λf. {h  hom_components (q' f). poly_deg h + poly_deg f  poly_deg p}"
  define F' where "F' = {f  F''. ((?A f)) * f  0}"
  define q where "q = (λf. ((?A f)) when f  F')"
  have "F'  F''" by (simp add: F'_def)
  hence "F'  F" using F''  F by (rule subset_trans)
  have 1: "deg_pm t + poly_deg f = poly_deg p" if "f  F'" and "t  keys (q f)" for f t
  proof -
    from that have "t  keys ((?A f))" by (simp add: q_def)
    also have "  (h?A f. keys h)" by (fact keys_sum_subset)
    finally obtain h where "h  ?A f" and "t  keys h" ..
    from this(1) have "h  hom_components (q' f)" and eq: "poly_deg h + poly_deg f = poly_deg p"
      by simp_all
    from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
    hence "deg_pm t = poly_deg h" using t  keys h by (rule homogeneousD_poly_deg)
    thus ?thesis by (simp only: eq)
  qed
  have 2: "deg_pm t = poly_deg p" if "f  F'" and "t  keys (q f * f)" for f t
  proof -
    from that(1) F'  F have "f  F" ..
    hence "homogeneous f" by (rule assms(1))
    from that(2) obtain s1 s2 where "s1  keys (q f)" and "s2  keys f" and t: "t = s1 + s2"
      by (rule in_keys_timesE)
    from that(1) this(1) have "deg_pm s1 + poly_deg f = poly_deg p" by (rule 1)
    moreover from ‹homogeneous f s2  keys f have "deg_pm s2 = poly_deg f"
      by (rule homogeneousD_poly_deg)
    ultimately show ?thesis by (simp add: t deg_pm_plus)
  qed
  from F'  F'' ‹finite F'' have "finite F'" by (rule finite_subset)
  thus ?thesis using F'  F
  proof
    note p
    also from refl have "(fF''. q' f * f) = (fF''. ((?A f) * f) + ((?B f) * f))"
    proof (rule sum.cong)
      fix f
      assume "f  F''"
      from sum_hom_components have "q' f = ((hom_components (q' f)))" by (rule sym)
      also have " = ((?A f  ?B f))" by (rule arg_cong[where f="sum (λx. x)"]) blast
      also have " = (?A f) + (?B f)"
      proof (rule sum.union_disjoint)
        have "?A f  hom_components (q' f)" by blast
        thus "finite (?A f)" using finite_hom_components by (rule finite_subset)
      next
        have "?B f  hom_components (q' f)" by blast
        thus "finite (?B f)" using finite_hom_components by (rule finite_subset)
      qed blast
      finally show "q' f * f = ((?A f) * f) + ((?B f) * f)"
        by (metis (no_types, lifting) distrib_right)
    qed
    also have " = (fF''. (?A f) * f) + (fF''. (?B f) * f)" by (rule sum.distrib)
    also from ‹finite F'' F'  F'' have "(fF''. (?A f) * f) = (fF'. q f * f)"
    proof (intro sum.mono_neutral_cong_right ballI)
      fix f
      assume "f  F'' - F'"
      thus "(?A f) * f = 0" by (simp add: F'_def)
    next
      fix f
      assume "f  F'"
      thus "(?A f) * f = q f * f" by (simp add: q_def)
    qed
    finally have p[symmetric]: "p = (fF'. q f * f) + (fF''. (?B f) * f)" .
    moreover have "keys (fF''. (?B f) * f) = {}"
    proof (rule, rule)
      fix t
      assume t_in: "t  keys (fF''. (?B f) * f)"
      also have "  (fF''. keys ((?B f) * f))" by (fact keys_sum_subset)
      finally obtain f where "f  F''" and "t  keys ((?B f) * f)" ..
      from this(2) obtain s1 s2 where "s1  keys ((?B f))" and "s2  keys f" and t: "t = s1 + s2"
        by (rule in_keys_timesE)
      from f  F'' F''  F have "f  F" ..
      hence "homogeneous f" by (rule assms(1))
      note s1  keys ((?B f))
      also have "keys ((?B f))  (h?B f. keys h)" by (fact keys_sum_subset)
      finally obtain h where "h  ?B f" and "s1  keys h" ..
      from this(1) have "h  hom_components (q' f)" and neq: "poly_deg h + poly_deg f  poly_deg p"
        by simp_all
      from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
      hence "deg_pm s1 = poly_deg h" using s1  keys h by (rule homogeneousD_poly_deg)
      moreover from ‹homogeneous f s2  keys f have "deg_pm s2 = poly_deg f"
        by (rule homogeneousD_poly_deg)
      ultimately have "deg_pm t  poly_deg p" using neq by (simp add: t deg_pm_plus)
      have "t  keys (fF'. q f * f)"
      proof
        assume "t  keys (fF'. q f * f)"
        also have "  (fF'. keys (q f * f))" by (fact keys_sum_subset)
        finally obtain f where "f  F'" and "t  keys (q f * f)" ..
        hence "deg_pm t = poly_deg p" by (rule 2)
        with ‹deg_pm t  poly_deg p show False ..
      qed
      with t_in have "t  keys ((fF'. q f * f) + (fF''. (?B f) * f))"
        by (rule in_keys_plusI2)
      hence "t  keys p" by (simp only: p)
      with assms(3) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
      with ‹deg_pm t  poly_deg p show "t  {}" ..
    qed (fact empty_subsetI)
    ultimately show "p = (fF'. q f * f)" by simp
  next
    fix f
    show "homogeneous (q f)"
    proof (cases "f  F'")
      case True
      show ?thesis
      proof (rule homogeneousI)
        fix s t
        assume "s  keys (q f)"
        with True have *: "deg_pm s + poly_deg f = poly_deg p" by (rule 1)
        assume "t  keys (q f)"
        with True have "deg_pm t + poly_deg f = poly_deg p" by (rule 1)
        with * show "deg_pm s = deg_pm t" by simp
      qed
    next
      case False
      thus ?thesis by (simp add: q_def)
    qed

    assume "f  F'"
    show "poly_deg (q f * f) = poly_deg p"
    proof (intro antisym)
      show "poly_deg (q f * f)  poly_deg p"
      proof (rule poly_deg_leI)
        fix t
        assume "t  keys (q f * f)"
        with f  F' have "deg_pm t = poly_deg p" by (rule 2)
        thus "deg_pm t  poly_deg p" by simp
      qed
    next
      from f  F' have "q f * f  0" by (simp add: q_def F'_def)
      hence "keys (q f * f)  {}" by simp
      then obtain t where "t  keys (q f * f)" by blast
      with f  F' have "deg_pm t = poly_deg p" by (rule 2)
      moreover from t  keys (q f * f) have "deg_pm t  poly_deg (q f * f)" by (rule poly_deg_max_keys)
      ultimately show "poly_deg p  poly_deg (q f * f)" by simp
    qed
  qed (simp add: q_def)
qed

corollary homogeneous_idealE:
  assumes "f. f  F  homogeneous f" and "p  ideal F"
  obtains F' q where "finite F'" and "F'  F" and "p = (fF'. q f * f)"
    and "f. poly_deg (q f * f)  poly_deg p" and "f. f  F'  q f = 0"
proof (cases "p = 0")
  case True
  show ?thesis
  proof
    show "p = (f{}. (λ_. 0) f * f)" by (simp add: True)
  qed simp_all
next
  case False
  define P where "P = (λh qf. finite (fst qf)  fst qf  F  h = (ffst qf. snd qf f * f) 
                  (ffst qf. poly_deg (snd qf f * f) = poly_deg h)  (f. f  fst qf  snd qf f = 0))"
  define q0 where "q0 = (λh. SOME qf. P h qf)"
  have 1: "P h (q0 h)" if "h  hom_components p" for h
  proof -
    note assms(1)
    moreover from assms that have "h  ideal F" by (rule homogeneous_ideal')
    moreover from that have "homogeneous h" by (rule hom_components_homogeneous)
    ultimately obtain F' q where "finite F'" and "F'  F" and "h = (fF'. q f * f)"
      and "f. f  F'  poly_deg (q f * f) = poly_deg h" and "f. f  F'  q f = 0"
      by (rule homogeneous_idealE_homogeneous) blast+
    hence "P h (F', q)" by (simp add: P_def)
    thus ?thesis unfolding q0_def by (rule someI)
  qed
  define F' where "F' = (hhom_components p. fst (q0 h))"
  define q where "q = (λf. hhom_components p. snd (q0 h) f)"
  show ?thesis
  proof
    have "finite F'  F'  F" unfolding F'_def UN_subset_iff finite_UN[OF finite_hom_components]
    proof (intro conjI ballI)
      fix h
      assume "h  hom_components p"
      hence "P h (q0 h)" by (rule 1)
      thus "finite (fst (q0 h))" and "fst (q0 h)  F" by (simp_all only: P_def)
    qed
    thus "finite F'" and "F'  F" by simp_all

    from sum_hom_components have "p = ((hom_components p))" by (rule sym)
    also from refl have " = (hhom_components p. fF'. snd (q0 h) f * f)"
    proof (rule sum.cong)
      fix h
      assume "h  hom_components p"
      hence "P h (q0 h)" by (rule 1)
      hence "h = (ffst (q0 h). snd (q0 h) f * f)" and 2: "f. f  fst (q0 h)  snd (q0 h) f = 0"
        by (simp_all add: P_def)
      note this(1)
      also from ‹finite F' have "(ffst (q0 h). (snd (q0 h)) f * f) = (fF'. snd (q0 h) f * f)"
      proof (intro sum.mono_neutral_left ballI)
        show "fst (q0 h)  F'" unfolding F'_def using h  hom_components p by blast
      next
        fix f
        assume "f  F' - fst (q0 h)"
        hence "f  fst (q0 h)" by simp
        hence "snd (q0 h) f = 0" by (rule 2)
        thus "snd (q0 h) f * f = 0" by simp
      qed
      finally show "h = (fF'. snd (q0 h) f * f)" .
    qed
    also have " = (fF'. hhom_components p. snd (q0 h) f * f)" by (rule sum.swap)
    also have " = (fF'. q f * f)" by (simp only: q_def sum_distrib_right)
    finally show "p = (fF'. q f * f)" .

    fix f
    have "poly_deg (q f * f) = poly_deg (hhom_components p. snd (q0 h) f * f)"
      by (simp only: q_def sum_distrib_right)
    also have "  Max (poly_deg ` (λh. snd (q0 h) f * f) ` hom_components p)"
      by (rule poly_deg_sum_le)
    also have " = Max ((λh. poly_deg (snd (q0 h) f * f)) ` hom_components p)"
      (is "_ = Max (?f ` _)") by (simp only: image_image)
    also have "  poly_deg p"
    proof (rule Max.boundedI)
      from finite_hom_components show "finite (?f ` hom_components p)" by (rule finite_imageI)
    next
      from False show "?f ` hom_components p  {}" by simp
    next
      fix d
      assume "d  ?f ` hom_components p"
      then obtain h where "h  hom_components p" and d: "d = ?f h" ..
      from this(1) have "P h (q0 h)" by (rule 1)
      hence 2: "f. f  fst (q0 h)  poly_deg (snd (q0 h) f * f) = poly_deg h"
        and 3: "f. f  fst (q0 h)  snd (q0 h) f = 0" by (simp_all add: P_def)
      show "d  poly_deg p"
      proof (cases "f  fst (q0 h)")
        case True
        hence "poly_deg (snd (q0 h) f * f) = poly_deg h" by (rule 2)
        hence "d = poly_deg h" by (simp only: d)
        also from h  hom_components p have "  poly_deg p" by (rule poly_deg_hom_components_le)
        finally show ?thesis .
      next
        case False
        hence "snd (q0 h) f = 0" by (rule 3)
        thus ?thesis by (simp add: d)
      qed
    qed
    finally show "poly_deg (q f * f)  poly_deg p" .

    assume "f  F'"
    show "q f = 0" unfolding q_def
    proof (intro sum.neutral ballI)
      fix h
      assume "h  hom_components p"
      hence "P h (q0 h)" by (rule 1)
      hence 2: "f. f  fst (q0 h)  snd (q0 h) f = 0" by (simp add: P_def)
      show "snd (q0 h) f = 0"
      proof (intro 2 notI)
        assume "f  fst (q0 h)"
        hence "f  F'" unfolding F'_def using h  hom_components p by blast
        with f  F' show False ..
      qed
    qed
  qed
qed

corollary homogeneous_idealE_finite:
  assumes "finite F" and "f. f  F  homogeneous f" and "p  ideal F"
  obtains q where "p = (fF. q f * f)" and "f. poly_deg (q f * f)  poly_deg p"
    and "f. f  F  q f = 0"
proof -
  from assms(2, 3) obtain F' q where "F'  F" and p: "p = (fF'. q f * f)"
    and "f. poly_deg (q f * f)  poly_deg p" and 1: "f. f  F'  q f = 0"
    by (rule homogeneous_idealE) blast+
  show ?thesis
  proof
    from assms(1) F'  F have "(fF'. q f * f) = (fF. q f * f)"
    proof (intro sum.mono_neutral_left ballI)
      fix f
      assume "f  F - F'"
      hence "f  F'" by simp
      hence "q f = 0" by (rule 1)
      thus "q f * f = 0" by simp
    qed
    thus "p = (fF. q f * f)" by (simp only: p)
  next
    fix f
    show "poly_deg (q f * f)  poly_deg p" by fact

    assume "f  F"
    with F'  F have "f  F'" by blast
    thus "q f = 0" by (rule 1)
  qed
qed

subsubsection ‹Homogenization and Dehomogenization›

definition homogenize :: "'x  (('x 0 nat) 0 'a)  (('x 0 nat) 0 'a::semiring_1)"
  where "homogenize x p = (tkeys p. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"

definition dehomo_subst :: "'x  'x  (('x 0 nat) 0 'a::zero_neq_one)"
  where "dehomo_subst x = (λy. if y = x then 1 else monomial 1 (Poly_Mapping.single y 1))"

definition dehomogenize :: "'x  (('x 0 nat) 0 'a)  (('x 0 nat) 0 'a::comm_semiring_1)"
  where "dehomogenize x = poly_subst (dehomo_subst x)"

lemma homogenize_zero [simp]: "homogenize x 0 = 0"
  by (simp add: homogenize_def)

lemma homogenize_uminus [simp]: "homogenize x (- p) = - homogenize x (p::_ 0 'a::ring_1)"
  by (simp add: homogenize_def keys_uminus sum.reindex inj_on_def single_uminus sum_negf)

lemma homogenize_monom_mult [simp]:
  "homogenize x (punit.monom_mult c t p) = punit.monom_mult c t (homogenize x p)"
  for c::"'a::{semiring_1,semiring_no_zero_divisors_cancel}"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof (cases "c = 0")
    case True
    thus ?thesis by simp
  next
    case False
    show ?thesis
      by (simp add: homogenize_def punit.keys_monom_mult p  0 False sum.reindex
          punit.lookup_monom_mult punit.monom_mult_sum_right poly_deg_monom_mult
          punit.monom_mult_monomial ac_simps deg_pm_plus)
  qed
qed

lemma homogenize_alt:
  "homogenize x p = (qhom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
proof -
  have "homogenize x p = (tKeys (hom_components p). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
    by (simp only: homogenize_def Keys_hom_components)
  also have " = (t( (keys ` hom_components p)). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
    by (simp only: Keys_def)
  also have " = (qhom_components p. (tkeys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
    by (auto intro!: sum.UNION_disjoint finite_hom_components finite_keys dest: hom_components_keys_disjoint)
  also have " = (qhom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
    using refl
  proof (rule sum.cong)
    fix q
    assume q: "q  hom_components p"
    hence "homogeneous q" by (rule hom_components_homogeneous)
    have "(tkeys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
          (tkeys q. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t))"
      using refl
    proof (rule sum.cong)
      fix t
      assume "t  keys q"
      with ‹homogeneous q have "deg_pm t = poly_deg q" by (rule homogeneousD_poly_deg)
      moreover from q t  keys q have "lookup q t = lookup p t" by (rule lookup_hom_components)
      ultimately show "monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) =
            punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t)"
        by (simp add: punit.monom_mult_monomial)
    qed
    also have " = punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q"
      by (simp only: poly_mapping_sum_monomials flip: punit.monom_mult_sum_right)
    finally show "(tkeys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
                  punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q" .
  qed
  finally show ?thesis .
qed

lemma keys_homogenizeE:
  assumes "t  keys (homogenize x p)"
  obtains t' where "t'  keys p" and "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
proof -
  note assms
  also have "keys (homogenize x p) 
            (tkeys p. keys (monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
    unfolding homogenize_def by (rule keys_sum_subset)
  finally obtain t' where "t'  keys p"
    and "t  keys (monomial (lookup p t') (Poly_Mapping.single x (poly_deg p - deg_pm t') + t'))" ..
  from this(2) have "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
    by (simp split: if_split_asm)
  with t'  keys p show ?thesis ..
qed

lemma keys_homogenizeE_alt:
  assumes "t  keys (homogenize x p)"
  obtains q t' where "q  hom_components p" and "t'  keys q"
    and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'"
proof -
  note assms
  also have "keys (homogenize x p) 
            (qhom_components p. keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q))"
    unfolding homogenize_alt by (rule keys_sum_subset)
  finally obtain q where q: "q  hom_components p"
    and "t  keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)" ..
  note this(2)
  also have "  (+) (Poly_Mapping.single x (poly_deg p - poly_deg q)) ` keys q"
    by (rule punit.keys_monom_mult_subset[simplified])
  finally obtain t' where "t'  keys q" and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" ..
  with q show ?thesis ..
qed

lemma deg_pm_homogenize:
  assumes "t  keys (homogenize x p)"
  shows "deg_pm t = poly_deg p"
proof -
  from assms obtain q t' where q: "q  hom_components p" and "t'  keys q"
    and t: "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" by (rule keys_homogenizeE_alt)
  from q have "homogeneous q" by (rule hom_components_homogeneous)
  hence "deg_pm t' = poly_deg q" using t'  keys q by (rule homogeneousD_poly_deg)
  moreover from q have "poly_deg q  poly_deg p" by (rule poly_deg_hom_components_le)
  ultimately show ?thesis by (simp add: t deg_pm_plus deg_pm_single)
qed

corollary homogeneous_homogenize: "homogeneous (homogenize x p)"
proof (rule homogeneousI)
  fix s t
  assume "s  keys (homogenize x p)"
  hence *: "deg_pm s = poly_deg p" by (rule deg_pm_homogenize)
  assume "t  keys (homogenize x p)"
  hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
  with * show "deg_pm s = deg_pm t" by simp
qed

corollary poly_deg_homogenize_le: "poly_deg (homogenize x p)  poly_deg p"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (homogenize x p)"
  hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
  thus "deg_pm t  poly_deg p" by simp
qed

lemma homogenize_id_iff [simp]: "homogenize x p = p  homogeneous p"
proof
  assume "homogenize x p = p"
  moreover have "homogeneous (homogenize x p)" by (fact homogeneous_homogenize)
  ultimately show "homogeneous p" by simp
next
  assume "homogeneous p"
  hence "hom_components p = (if p = 0 then {} else {p})" by (rule hom_components_of_homogeneous)
  thus "homogenize x p = p" by (simp add: homogenize_alt split: if_split_asm)
qed

lemma homogenize_homogenize [simp]: "homogenize x (homogenize x p) = homogenize x p"
  by (simp add: homogeneous_homogenize)

lemma homogenize_monomial: "homogenize x (monomial c t) = monomial c t"
  by (simp only: homogenize_id_iff homogeneous_monomial)

lemma indets_homogenize_subset: "indets (homogenize x p)  insert x (indets p)"
proof
  fix y
  assume "y  indets (homogenize x p)"
  then obtain t where "t  keys (homogenize x p)" and "y  keys t" by (rule in_indetsE)
  from this(1) obtain t' where "t'  keys p"
    and t: "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'" by (rule keys_homogenizeE)
  note y  keys t
  also have "keys t  keys (Poly_Mapping.single x (poly_deg p - deg_pm t'))  keys t'"
    unfolding t by (rule Poly_Mapping.keys_add)
  finally show "y  insert x (indets p)"
  proof
    assume "y  keys (Poly_Mapping.single x (poly_deg p - deg_pm t'))"
    thus ?thesis by (simp split: if_split_asm)
  next
    assume "y  keys t'"
    hence "y  indets p" using t'  keys p by (rule in_indetsI)
    thus ?thesis by simp
  qed
qed

lemma homogenize_in_Polys: "p  P[X]  homogenize x p  P[insert x X]"
  using indets_homogenize_subset[of x p] by (auto simp: Polys_alt)

lemma lookup_homogenize:
  assumes "x  indets p" and "x  keys t"
  shows "lookup (homogenize x p) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) = lookup p t"
proof -
  let ?p = "homogenize x p"
  let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t) + t"
  have eq: "(skeys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t) = 0"
  proof (intro sum.neutral ballI)
    fix s
    assume "s  keys p - {t}"
    hence "s  keys p" and "s  t" by simp_all
    from this(1) have "keys s  indets p" by (simp add: in_indetsI subsetI)
    with assms(1) have "x  keys s" by blast
    have "?t  Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
    proof
      assume a: "?t = Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
      hence "lookup ?t x = lookup (Poly_Mapping.single x (poly_deg p - deg_pm s) + s) x"
        by simp
      moreover from assms(2) have "lookup t x = 0" by (simp add: in_keys_iff)
      moreover from x  keys s have "lookup s x = 0" by (simp add: in_keys_iff)
      ultimately have "poly_deg p - deg_pm t = poly_deg p - deg_pm s" by (simp add: lookup_add)
      with a have "s = t" by simp
      with s  t show False ..
    qed
    thus "lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t = 0"
      by (simp add: lookup_single)
  qed
  show ?thesis
  proof (cases "t  keys p")
    case True
    have "lookup ?p ?t = (skeys p. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
      by (simp add: homogenize_def lookup_sum)
    also have " = lookup (monomial (lookup p t) ?t) ?t +
                    (skeys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
      using finite_keys True by (rule sum.remove)
    also have " = lookup p t" by (simp add: eq)
    finally show ?thesis .
  next
    case False
    hence 1: "keys p - {t} = keys p" by simp
    have "lookup ?p ?t = (skeys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
      by (simp add: homogenize_def lookup_sum 1)
    also have " = 0" by (simp only: eq)
    also from False have " = lookup p t" by (simp add: in_keys_iff)
    finally show ?thesis .
  qed
qed

lemma keys_homogenizeI:
  assumes "x  indets p" and "t  keys p"
  shows "Poly_Mapping.single x (poly_deg p - deg_pm t) + t  keys (homogenize x p)" (is "?t  keys ?p")
proof -
  from assms(2) have "keys t  indets p" by (simp add: in_indetsI subsetI)
  with assms(1) have "x  keys t" by blast
  with assms(1) have "lookup ?p ?t = lookup p t" by (rule lookup_homogenize)
  also from assms(2) have "  0" by (simp add: in_keys_iff)
  finally show ?thesis by (simp add: in_keys_iff)
qed

lemma keys_homogenize:
  "x  indets p  keys (homogenize x p) = (λt. Poly_Mapping.single x (poly_deg p - deg_pm t) + t) ` keys p"
  by (auto intro: keys_homogenizeI elim: keys_homogenizeE)

lemma card_keys_homogenize:
  assumes "x  indets p"
  shows "card (keys (homogenize x p)) = card (keys p)"
  unfolding keys_homogenize[OF assms]
proof (intro card_image inj_onI)
  fix s t
  assume "s  keys p" and "t  keys p"
  with assms have "x  keys s" and "x  keys t" by (auto dest: in_indetsI simp only:)
  let ?s = "Poly_Mapping.single x (poly_deg p - deg_pm s)"
  let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t)"
  assume "?s + s = ?t + t"
  hence "lookup (?s + s) x = lookup (?t + t) x" by simp
  with x  keys s x  keys t have "?s = ?t" by (simp add: lookup_add in_keys_iff)
  with ?s + s = ?t + t show "s = t" by simp
qed

lemma poly_deg_homogenize:
  assumes "x  indets p"
  shows "poly_deg (homogenize x p) = poly_deg p"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  then obtain t where "t  keys p" and 1: "poly_deg p = deg_pm t" by (rule poly_degE)
  from assms this(1) have "Poly_Mapping.single x (poly_deg p - deg_pm t) + t  keys (homogenize x p)"
    by (rule keys_homogenizeI)
  hence "t  keys (homogenize x p)" by (simp add: 1)
  hence "poly_deg p  poly_deg (homogenize x p)" unfolding 1 by (rule poly_deg_max_keys)
  with poly_deg_homogenize_le show ?thesis by (rule antisym)
qed

lemma maxdeg_homogenize:
  assumes "x   (indets ` F)"
  shows "maxdeg (homogenize x ` F) = maxdeg F"
  unfolding maxdeg_def image_image
proof (rule arg_cong[where f=Max], rule set_eqI)
  fix d
  show "d  (λf. poly_deg (homogenize x f)) ` F  d  poly_deg ` F"
  proof
    assume "d  (λf. poly_deg (homogenize x f)) ` F"
    then obtain f where "f  F" and d: "d = poly_deg (homogenize x f)" ..
    from assms this(1) have "x  indets f" by blast
    hence "d = poly_deg f" by (simp add: d poly_deg_homogenize)
    with f  F show "d  poly_deg ` F" by (rule rev_image_eqI)
  next
    assume "d  poly_deg ` F"
    then obtain f where "f  F" and d: "d = poly_deg f" ..
    from assms this(1) have "x  indets f" by blast
    hence "d = poly_deg (homogenize x f)" by (simp add: d poly_deg_homogenize)
    with f  F show "d  (λf. poly_deg (homogenize x f)) ` F" by (rule rev_image_eqI)
  qed
qed

lemma homogeneous_ideal_homogenize:
  assumes "f. f  F  homogeneous f" and "p  ideal F"
  shows "homogenize x p  ideal F"
proof -
  have "homogenize x p = (qhom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
    by (fact homogenize_alt)
  also have "  ideal F"
  proof (rule ideal.span_sum)
    fix q
    assume "q  hom_components p"
    with assms have "q  ideal F" by (rule homogeneous_ideal')
    thus "punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q  ideal F"
      by (rule punit.pmdl_closed_monom_mult[simplified])
  qed
  finally show ?thesis .
qed

lemma subst_pp_dehomo_subst [simp]:
  "subst_pp (dehomo_subst x) t = monomial (1::'b::comm_semiring_1) (except t {x})"
proof -
  have "subst_pp (dehomo_subst x) t = ((ykeys t. dehomo_subst x y ^ lookup t y)::_ 0 'b)"
    by (fact subst_pp_def)
  also have " = (ykeys t - {y0. dehomo_subst x y0 ^ lookup t y0 = (1::_ 0 'b)}. dehomo_subst x y ^ lookup t y)"
    by (rule sym, rule prod.setdiff_irrelevant, fact finite_keys)
  also have " = (ykeys t - {x}. monomial 1 (Poly_Mapping.single y 1) ^ lookup t y)"
  proof (rule prod.cong)
    have "dehomo_subst x x ^ lookup t x = 1" by (simp add: dehomo_subst_def)
    moreover {
      fix y
      assume "y  x"
      hence "dehomo_subst x y ^ lookup t y = monomial 1 (Poly_Mapping.single y (lookup t y))"
        by (simp add: dehomo_subst_def monomial_single_power)
      moreover assume "dehomo_subst x y ^ lookup t y = 1"
      ultimately have "Poly_Mapping.single y (lookup t y) = 0"
        by (smt single_one monomial_inj zero_neq_one)
      hence "lookup t y = 0" by (rule monomial_0D)
      moreover assume "y  keys t"
      ultimately have False by (simp add: in_keys_iff)
    }
    ultimately show "keys t - {y0. dehomo_subst x y0 ^ lookup t y0 = 1} = keys t - {x}" by auto
  qed (simp add: dehomo_subst_def)
  also have " = (ykeys t - {x}. monomial 1 (Poly_Mapping.single y (lookup t y)))"
    by (simp add: monomial_single_power)
  also have " = monomial 1 (ykeys t - {x}. Poly_Mapping.single y (lookup t y))"
    by (simp flip: punit.monomial_prod_sum)
  also have "(ykeys t - {x}. Poly_Mapping.single y (lookup t y)) = except t {x}"
  proof (rule poly_mapping_eqI, simp add: lookup_sum lookup_except lookup_single, rule)
    fix y
    assume "y  x"
    show "(zkeys t - {x}. lookup t z when z = y) = lookup t y"
    proof (cases "y  keys t")
      case True
      have "finite (keys t - {x})" by simp
      moreover from True y  x have "y  keys t - {x}" by simp
      ultimately have "(zkeys t - {x}. lookup t z when z = y) =
                        (lookup t y when y = y) + (zkeys t - {x} - {y}. lookup t z when z = y)"
        by (rule sum.remove)
      also have "(zkeys t - {x} - {y}. lookup t z when z = y) = 0" by auto
      finally show ?thesis by simp
    next
      case False
      hence "(zkeys t - {x}. lookup t z when z = y) = 0" by (auto simp: when_def)
      also from False have " = lookup t y" by (simp add: in_keys_iff)
      finally show ?thesis .
    qed
  qed
  finally show ?thesis .
qed

lemma
  shows dehomogenize_zero [simp]: "dehomogenize x 0 = 0"
    and dehomogenize_one [simp]: "dehomogenize x 1 = 1"
    and dehomogenize_monomial: "dehomogenize x (monomial c t) = monomial c (except t {x})"
    and dehomogenize_plus: "dehomogenize x (p + q) = dehomogenize x p + dehomogenize x q"
    and dehomogenize_uminus: "dehomogenize x (- r) = - dehomogenize x (r::_ 0 _::comm_ring_1)"
    and dehomogenize_minus: "dehomogenize x (r - r') = dehomogenize x r - dehomogenize x r'"
    and dehomogenize_times: "dehomogenize x (p * q) = dehomogenize x p * dehomogenize x q"
    and dehomogenize_power: "dehomogenize x (p ^ n) = dehomogenize x p ^ n"
    and dehomogenize_sum: "dehomogenize x (sum f A) = (aA. dehomogenize x (f a))"
    and dehomogenize_prod: "dehomogenize x (prod f A) = (aA. dehomogenize x (f a))"
  by (simp_all add: dehomogenize_def poly_subst_monomial poly_subst_plus poly_subst_uminus
      poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod punit.monom_mult_monomial)

corollary dehomogenize_monom_mult:
  "dehomogenize x (punit.monom_mult c t p) = punit.monom_mult c (except t {x}) (dehomogenize x p)"
  by (simp only: times_monomial_left[symmetric] dehomogenize_times dehomogenize_monomial)

lemma poly_deg_dehomogenize_le: "poly_deg (dehomogenize x p)  poly_deg p"
  unfolding dehomogenize_def dehomo_subst_def
  by (rule poly_deg_poly_subst_le) (simp add: poly_deg_monomial deg_pm_single)

lemma indets_dehomogenize: "indets (dehomogenize x p)  indets p - {x}"
  for p::"('x 0 nat) 0 'a::comm_semiring_1"
proof
  fix y::'x
  assume "y  indets (dehomogenize x p)"
  then obtain y' where "y'  indets p" and "y  indets ((dehomo_subst x y')::_ 0 'a)"
    unfolding dehomogenize_def by (rule in_indets_poly_substE)
  from this(2) have "y = y'" and "y'  x"
    by (simp_all add: dehomo_subst_def indets_monomial split: if_split_asm)
  with y'  indets p show "y  indets p - {x}" by simp
qed

lemma dehomogenize_id_iff [simp]: "dehomogenize x p = p  x  indets p"
proof
  assume eq: "dehomogenize x p = p"
  from indets_dehomogenize[of x p] show "x  indets p" by (auto simp: eq)
next
  assume a: "x  indets p"
  show "dehomogenize x p = p" unfolding dehomogenize_def
  proof (rule poly_subst_id)
    fix y
    assume "y  indets p"
    with a have "y  x" by blast
    thus "dehomo_subst x y = monomial 1 (Poly_Mapping.single y 1)" by (simp add: dehomo_subst_def)
  qed
qed

lemma dehomogenize_dehomogenize [simp]: "dehomogenize x (dehomogenize x p) = dehomogenize x p"
proof -
  from indets_dehomogenize[of x p] have "x  indets (dehomogenize x p)" by blast
  thus ?thesis by simp
qed

lemma dehomogenize_homogenize [simp]: "dehomogenize x (homogenize x p) = dehomogenize x p"
proof -
  have "dehomogenize x (homogenize x p) = sum (dehomogenize x) (hom_components p)"
    by (simp add: homogenize_alt dehomogenize_sum dehomogenize_monom_mult except_single)
  also have " = dehomogenize x p" by (simp only: sum_hom_components flip: dehomogenize_sum)
  finally show ?thesis .
qed

corollary dehomogenize_homogenize_id: "x  indets p  dehomogenize x (homogenize x p) = p"
  by simp

lemma range_dehomogenize: "range (dehomogenize x) = (P[- {x}] :: (_ 0 'a::comm_semiring_1) set)"
proof (intro subset_antisym subsetI PolysI_alt range_eqI)
  fix p::"_ 0 'a" and y
  assume "p  range (dehomogenize x)"
  then obtain q where p: "p = dehomogenize x q" ..
  assume "y  indets p"
  hence "y  indets (dehomogenize x q)" by (simp only: p)
  with indets_dehomogenize have "y  indets q - {x}" ..
  thus "y  - {x}" by simp
next
  fix p::"_ 0 'a"
  assume "p  P[- {x}]"
  hence "x  indets p" by (auto dest: PolysD)
  thus "p = dehomogenize x (homogenize x p)" by (rule dehomogenize_homogenize_id[symmetric])
qed

lemma dehomogenize_alt: "dehomogenize x p = (tkeys p. monomial (lookup p t) (except t {x}))"
proof -
  have "dehomogenize x p = dehomogenize x (tkeys p. monomial (lookup p t) t)"
    by (simp only: poly_mapping_sum_monomials)
  also have " = (tkeys p. monomial (lookup p t) (except t {x}))"
    by (simp only: dehomogenize_sum dehomogenize_monomial)
  finally show ?thesis .
qed

lemma keys_dehomogenizeE:
  assumes "t  keys (dehomogenize x p)"
  obtains s where "s  keys p" and "t = except s {x}"
proof -
  note assms
  also have "keys (dehomogenize x p)  (skeys p. keys (monomial (lookup p s) (except s {x})))"
    unfolding dehomogenize_alt by (rule keys_sum_subset)
  finally obtain s where "s  keys p" and "t  keys (monomial (lookup p s) (except s {x}))" ..
  from this(2) have "t = except s {x}" by (simp split: if_split_asm)
  with s  keys p show ?thesis ..
qed

lemma except_inj_on_keys_homogeneous:
  assumes "homogeneous p"
  shows "inj_on (λt. except t {x}) (keys p)"
proof
  fix s t
  assume "s  keys p" and "t  keys p"
  from assms this(1) have "deg_pm s = poly_deg p" by (rule homogeneousD_poly_deg)
  moreover from assms t  keys p have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
  ultimately have "deg_pm (Poly_Mapping.single x (lookup s x) + except s {x}) =
                   deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
    by (simp only: flip: plus_except)
  moreover assume 1: "except s {x} = except t {x}"
  ultimately have 2: "lookup s x = lookup t x"
    by (simp only: deg_pm_plus deg_pm_single)
  show "s = t"
  proof (rule poly_mapping_eqI)
    fix y
    show "lookup s y = lookup t y"
    proof (cases "y = x")
      case True
      with 2 show ?thesis by simp
    next
      case False
      hence "lookup s y = lookup (except s {x}) y" and "lookup t y = lookup (except t {x}) y"
        by (simp_all add: lookup_except)
      with 1 show ?thesis by simp
    qed
  qed
qed

lemma lookup_dehomogenize:
  assumes "homogeneous p" and "t  keys p"
  shows "lookup (dehomogenize x p) (except t {x}) = lookup p t"
proof -
  let ?t = "except t {x}"
  have eq: "(skeys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t) = 0"
  proof (intro sum.neutral ballI)
    fix s
    assume "s  keys p - {t}"
    hence "s  keys p" and "s  t" by simp_all
    have "?t  except s {x}"
    proof
      from assms(1) have "inj_on (λt. except t {x}) (keys p)" by (rule except_inj_on_keys_homogeneous)
      moreover assume "?t = except s {x}"
      ultimately have "t = s" using assms(2) s  keys p by (rule inj_onD)
      with s  t show False by simp
    qed
    thus "lookup (monomial (lookup p s) (except s {x})) ?t = 0" by (simp add: lookup_single)
  qed
  have "lookup (dehomogenize x p) ?t = (skeys p. lookup (monomial (lookup p s) (except s {x})) ?t)"
    by (simp only: dehomogenize_alt lookup_sum)
  also have " = lookup (monomial (lookup p t) ?t) ?t +
                  (skeys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t)"
    using finite_keys assms(2) by (rule sum.remove)
  also have " = lookup p t" by (simp add: eq)
  finally show ?thesis .
qed

lemma keys_dehomogenizeI:
  assumes "homogeneous p" and "t  keys p"
  shows "except t {x}  keys (dehomogenize x p)"
proof -
  from assms have "lookup (dehomogenize x p) (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
  also from assms(2) have "  0" by (simp add: in_keys_iff)
  finally show ?thesis by (simp add: in_keys_iff)
qed

lemma homogeneous_homogenize_dehomogenize:
  assumes "homogeneous p"
  obtains d where "d = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
    and "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
proof (cases "p = 0")
  case True
  hence "0 = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
    and "punit.monom_mult 1 (Poly_Mapping.single x 0) (homogenize x (dehomogenize x p)) = p"
    by simp_all
  thus ?thesis ..
next
  case False
  let ?q = "dehomogenize x p"
  let ?p = "homogenize x ?q"
  define d where "d = poly_deg p - poly_deg ?p"
  show ?thesis
  proof
    have "punit.monom_mult 1 (Poly_Mapping.single x d) ?p =
          (tkeys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t))"
      by (simp add: homogenize_def punit.monom_mult_sum_right punit.monom_mult_monomial flip: add.assoc single_add)
    also have " = (tkeys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
      using refl
    proof (rule sum.cong)
      fix t
      assume "t  keys ?q"
      have "poly_deg ?p = poly_deg ?q"
      proof (rule poly_deg_homogenize)
        from indets_dehomogenize show "x  indets ?q" by fastforce
      qed
      hence d: "d = poly_deg p - poly_deg ?q" by (simp only: d_def)
      thm poly_deg_dehomogenize_le
      from t  keys ?q have "d + (poly_deg ?q - deg_pm t) = (d + poly_deg ?q) - deg_pm t"
        by (intro add_diff_assoc poly_deg_max_keys)
      also have "d + poly_deg ?q = poly_deg p" by (simp add: d poly_deg_dehomogenize_le)
      finally show "monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t) =
                    monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)"
        by (simp only:)
    qed
    also have " = (t(λs. except s {x}) ` keys p.
                    monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
    proof (rule sum.mono_neutral_left)
      show "keys (dehomogenize x p)  (λs. except s {x}) ` keys p"
      proof
        fix t
        assume "t  keys (dehomogenize x p)"
        then obtain s where "s  keys p" and "t = except s {x}" by (rule keys_dehomogenizeE)
        thus "t  (λs. except s {x}) ` keys p" by (rule rev_image_eqI)
      qed
    qed (simp_all add: in_keys_iff)
    also from assms have " = (tkeys p. monomial (lookup ?q (except t {x}))
                (Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}))"
      by (intro sum.reindex[unfolded comp_def] except_inj_on_keys_homogeneous)
    also from refl have " = (tkeys p. monomial (lookup p t) t)"
    proof (rule sum.cong)
      fix t
      assume "t  keys p"
      with assms have "lookup ?q (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
      moreover have "Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x} = t"
        (is "?l = _")
      proof (rule poly_mapping_eqI)
        fix y
        show "lookup ?l y = lookup t y"
        proof (cases "y = x")
          case True
          from assms t  keys p have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
          also have "deg_pm t = deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
            by (simp flip: plus_except)
          also have " = lookup t x + deg_pm (except t {x})" by (simp only: deg_pm_plus deg_pm_single)
          finally have "poly_deg p - deg_pm (except t {x}) = lookup t x" by simp
          thus ?thesis by (simp add: True lookup_add lookup_except lookup_single)
        next
          case False
          thus ?thesis by (simp add: lookup_add lookup_except lookup_single)
        qed
      qed
      ultimately show "monomial (lookup ?q (except t {x}))
              (Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}) =
            monomial (lookup p t) t" by (simp only:)
    qed
    also have " = p" by (fact poly_mapping_sum_monomials)
    finally show "punit.monom_mult 1 (Poly_Mapping.single x d) ?p = p" .
  qed (simp only: d_def)
qed

lemma dehomogenize_zeroD:
  assumes "dehomogenize x p = 0" and "homogeneous p"
  shows "p = 0"
proof -
  from assms(2) obtain d
    where "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
    by (rule homogeneous_homogenize_dehomogenize)
  thus ?thesis by (simp add: assms(1))
qed

lemma dehomogenize_ideal: "dehomogenize x ` ideal F = ideal (dehomogenize x ` F)  P[- {x}]"
  unfolding range_dehomogenize[symmetric]
  using dehomogenize_plus dehomogenize_times dehomogenize_dehomogenize by (rule image_ideal_eq_Int)

corollary dehomogenize_ideal_subset: "dehomogenize x ` ideal F  ideal (dehomogenize x ` F)"
  by (simp add: dehomogenize_ideal)

lemma ideal_dehomogenize:
  assumes "ideal G = ideal (homogenize x ` F)" and "F  P[UNIV - {x}]"
  shows "ideal (dehomogenize x ` G) = ideal F"
proof -
  have eq: "dehomogenize x (homogenize x f) = f" if "f  F" for f
  proof (rule dehomogenize_homogenize_id)
    from that assms(2) have "f  P[UNIV - {x}]" ..
    thus "x  indets f" by (auto simp: Polys_alt)
  qed
  show ?thesis
  proof (intro Set.equalityI ideal.span_subset_spanI)
    show "dehomogenize x ` G  ideal F"
    proof
      fix q
      assume "q  dehomogenize x ` G"
      then obtain g where "g  G" and q: "q = dehomogenize x g" ..
      from this(1) have "g  ideal G" by (rule ideal.span_base)
      also have " = ideal (homogenize x ` F)" by fact
      finally have "q  dehomogenize x ` ideal (homogenize x ` F)" using q by (rule rev_image_eqI)
      also have "  ideal (dehomogenize x ` homogenize x ` F)" by (rule dehomogenize_ideal_subset)
      also have "dehomogenize x ` homogenize x ` F = F"
        by (auto simp: eq image_image simp del: dehomogenize_homogenize intro!: image_eqI)
      finally show "q  ideal F" .
    qed
  next
    show "F  ideal (dehomogenize x ` G)"
    proof
      fix f
      assume "f  F"
      hence "homogenize x f  homogenize x ` F" by (rule imageI)
      also have "  ideal (homogenize x ` F)" by (rule ideal.span_superset)
      also from assms(1) have " = ideal G" by (rule sym)
      finally have "dehomogenize x (homogenize x f)  dehomogenize x ` ideal G" by (rule imageI)
      with f  F have "f  dehomogenize x ` ideal G" by (simp only: eq)
      also have "  ideal (dehomogenize x ` G)" by (rule dehomogenize_ideal_subset)
      finally show "f  ideal (dehomogenize x ` G)" .
    qed
  qed
qed

subsection ‹Embedding Polynomial Rings in Larger Polynomial Rings (With One Additional Indeterminate)›

text ‹We define a homomorphism for embedding a polynomial ring in a larger polynomial ring, and its
  inverse. This is mainly needed for homogenizing wrt. a fresh indeterminate.›

definition extend_indets_subst :: "'x  ('x option 0 nat) 0 'a::comm_semiring_1"
  where "extend_indets_subst x = monomial 1 (Poly_Mapping.single (Some x) 1)"

definition extend_indets :: "(('x 0 nat) 0 'a)  ('x option 0 nat) 0 'a::comm_semiring_1"
  where "extend_indets = poly_subst extend_indets_subst"

definition restrict_indets_subst :: "'x option  'x 0 nat"
  where "restrict_indets_subst x = (case x of Some y  Poly_Mapping.single y 1 | _  0)"

definition restrict_indets :: "(('x option 0 nat) 0 'a)  ('x 0 nat) 0 'a::comm_semiring_1"
  where "restrict_indets = poly_subst (λx. monomial 1 (restrict_indets_subst x))"

definition restrict_indets_pp :: "('x option 0 nat)  ('x 0 nat)"
  where "restrict_indets_pp t = (xkeys t. lookup t x  restrict_indets_subst x)"

lemma lookup_extend_indets_subst_aux:
  "lookup (ykeys t. Poly_Mapping.single (Some y) (lookup t y)) = (λx. case x of Some y  lookup t y | _  0)"
proof -
  have "(xkeys t. lookup t x when x = y) = lookup t y" for y
  proof (cases "y  keys t")
    case True
    hence "(xkeys t. lookup t x when x = y) = (xinsert y (keys t). lookup t x when x = y)"
      by (simp only: insert_absorb)
    also have " = lookup t y + (xkeys t - {y}. lookup t x when x = y)"
      by (simp add: sum.insert_remove)
    also have "(xkeys t - {y}. lookup t x when x = y) = 0"
      by (auto simp: when_def intro: sum.neutral)
    finally show ?thesis by simp
  next
    case False
    hence "(xkeys t. lookup t x when x = y) = 0" by (auto simp: when_def intro: sum.neutral)
    with False show ?thesis by (simp add: in_keys_iff)
  qed
  thus ?thesis by (auto simp: lookup_sum lookup_single split: option.split)
qed

lemma keys_extend_indets_subst_aux:
  "keys (ykeys t. Poly_Mapping.single (Some y) (lookup t y)) = Some ` keys t"
  by (auto simp: lookup_extend_indets_subst_aux simp flip: lookup_not_eq_zero_eq_in_keys split: option.splits)

lemma subst_pp_extend_indets_subst:
  "subst_pp extend_indets_subst t = monomial 1 (ykeys t. Poly_Mapping.single (Some y) (lookup t y))"
proof -
  have "subst_pp extend_indets_subst t =
      monomial (ykeys t. 1 ^ lookup t y) (ykeys t. lookup t y  Poly_Mapping.single (Some y) 1)"
    by (rule subst_pp_by_monomials) (simp only: extend_indets_subst_def)
  also have " = monomial 1 (ykeys t. Poly_Mapping.single (Some y) (lookup t y))"
    by simp
  finally show ?thesis .
qed

lemma keys_extend_indets:
  "keys (extend_indets p) = (λt. ykeys t. Poly_Mapping.single (Some y) (lookup t y)) ` keys p"
proof -
  have "keys (extend_indets p) = (tkeys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)))"
    unfolding extend_indets_def poly_subst_def using finite_keys
  proof (rule keys_sum)
    fix s t :: "'a 0 nat"
    assume "s  t"
    then obtain x where "lookup s x  lookup t x" by (meson poly_mapping_eqI)
    have "(ykeys t. monomial (lookup t y) (Some y))  (ykeys s. monomial (lookup s y) (Some y))"
      (is "?l  ?r")
    proof
      assume "?l = ?r"
      hence "lookup ?l (Some x) = lookup ?r (Some x)" by (simp only:)
      hence "lookup s x = lookup t x" by (simp add: lookup_extend_indets_subst_aux)
      with ‹lookup s x  lookup t x show False ..
    qed
    thus "keys (punit.monom_mult (lookup p s) 0 (subst_pp extend_indets_subst s)) 
          keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)) =
          {}"
      by (simp add: subst_pp_extend_indets_subst punit.monom_mult_monomial)
  qed
  also have " = (λt. ykeys t. monomial (lookup t y) (Some y)) ` keys p"
    by (auto simp: subst_pp_extend_indets_subst punit.monom_mult_monomial split: if_split_asm)
  finally show ?thesis .
qed

lemma indets_extend_indets: "indets (extend_indets p) = Some ` indets (p::_ 0 'a::comm_semiring_1)"
proof (rule set_eqI)
  fix x
  show "x  indets (extend_indets p)  x  Some ` indets p"
  proof
    assume "x  indets (extend_indets p)"
    then obtain y where "y  indets p" and "x  indets (monomial (1::'a) (Poly_Mapping.single (Some y) 1))"
      unfolding extend_indets_def extend_indets_subst_def by (rule in_indets_poly_substE)
    from this(2) indets_monomial_single_subset have "x  {Some y}" ..
    hence "x = Some y" by simp
    with y  indets p show "x  Some ` indets p" by (rule rev_image_eqI)
  next
    assume "x  Some ` indets p"
    then obtain y where "y  indets p" and x: "x = Some y" ..
    from this(1) obtain t where "t  keys p" and "y  keys t" by (rule in_indetsE)
    from this(2) have "Some y  keys (ykeys t. Poly_Mapping.single (Some y) (lookup t y))"
      unfolding keys_extend_indets_subst_aux by (rule imageI)
    moreover have "(ykeys t. Poly_Mapping.single (Some y) (lookup t y))  keys (extend_indets p)"
      unfolding keys_extend_indets using t  keys p by (rule imageI)
    ultimately show "x  indets (extend_indets p)" unfolding x by (rule in_indetsI)
  qed
qed

lemma poly_deg_extend_indets [simp]: "poly_deg (extend_indets p) = poly_deg p"
proof -
  have eq: "deg_pm ((ykeys t. Poly_Mapping.single (Some y) (lookup t y))) = deg_pm t"
    for t::"'a 0 nat"
  proof -
    have "deg_pm ((ykeys t. Poly_Mapping.single (Some y) (lookup t y))) = (ykeys t. lookup t y)"
      by (simp add: deg_pm_sum deg_pm_single)
    also from subset_refl finite_keys have " = deg_pm t" by (rule deg_pm_superset[symmetric])
    finally show ?thesis .
  qed
  show ?thesis
  proof (rule antisym)
    show "poly_deg (extend_indets p)  poly_deg p"
    proof (rule poly_deg_leI)
      fix t
      assume "t  keys (extend_indets p)"
      then obtain s where "s  keys p" and "t = (ykeys s. Poly_Mapping.single (Some y) (lookup s y))"
        unfolding keys_extend_indets ..
      from this(2) have "deg_pm t = deg_pm s" by (simp only: eq)
      also from s  keys p have "  poly_deg p" by (rule poly_deg_max_keys)
      finally show "deg_pm t  poly_deg p" .
    qed
  next
    show "poly_deg p  poly_deg (extend_indets p)"
    proof (rule poly_deg_leI)
      fix t
      assume "t  keys p"
      hence *: "(ykeys t. Poly_Mapping.single (Some y) (lookup t y))  keys (extend_indets p)"
        unfolding keys_extend_indets by (rule imageI)
      have "deg_pm t = deg_pm (ykeys t. Poly_Mapping.single (Some y) (lookup t y))"
        by (simp only: eq)
      also from * have "  poly_deg (extend_indets p)" by (rule poly_deg_max_keys)
      finally show "deg_pm t  poly_deg (extend_indets p)" .
    qed
  qed
qed

lemma
  shows extend_indets_zero [simp]: "extend_indets 0 = 0"
    and extend_indets_one [simp]: "extend_indets 1 = 1"
    and extend_indets_monomial: "extend_indets (monomial c t) = punit.monom_mult c 0 (subst_pp extend_indets_subst t)"
    and extend_indets_plus: "extend_indets (p + q) = extend_indets p + extend_indets q"
    and extend_indets_uminus: "extend_indets (- r) = - extend_indets (r::_ 0 _::comm_ring_1)"
    and extend_indets_minus: "extend_indets (r - r') = extend_indets r - extend_indets r'"
    and extend_indets_times: "extend_indets (p * q) = extend_indets p * extend_indets q"
    and extend_indets_power: "extend_indets (p ^ n) = extend_indets p ^ n"
    and extend_indets_sum: "extend_indets (sum f A) = (aA. extend_indets (f a))"
    and extend_indets_prod: "extend_indets (prod f A) = (aA. extend_indets (f a))"
  by (simp_all add: extend_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
      poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod)

lemma extend_indets_zero_iff [simp]: "extend_indets p = 0  p = 0"
  by (metis (no_types, lifting) imageE imageI keys_extend_indets lookup_zero
      not_in_keys_iff_lookup_eq_zero poly_deg_extend_indets poly_deg_zero poly_deg_zero_imp_monomial)

lemma extend_indets_inject:
  assumes "extend_indets p = extend_indets (q::_ 0 _::comm_ring_1)"
  shows "p = q"
proof -
  from assms have "extend_indets (p - q) = 0" by (simp add: extend_indets_minus)
  thus ?thesis by simp
qed

corollary inj_extend_indets: "inj (extend_indets::_  _ 0 _::comm_ring_1)"
  using extend_indets_inject by (intro injI)

lemma poly_subst_extend_indets: "poly_subst f (extend_indets p) = poly_subst (f  Some) p"
  by (simp add: extend_indets_def poly_subst_poly_subst extend_indets_subst_def poly_subst_monomial
          subst_pp_single o_def)

lemma poly_eval_extend_indets: "poly_eval a (extend_indets p) = poly_eval (a  Some) p"
proof -
  have eq: "poly_eval a (extend_indets (monomial c t)) = poly_eval (λx. a (Some x)) (monomial c t)"
    for c t
    by (simp add: extend_indets_monomial poly_eval_times poly_eval_monomial poly_eval_prod poly_eval_power
                subst_pp_def extend_indets_subst_def flip: times_monomial_left)
  show ?thesis
    by (induct p rule: poly_mapping_plus_induct) (simp_all add: extend_indets_plus poly_eval_plus eq)
qed

lemma lookup_restrict_indets_pp: "lookup (restrict_indets_pp t) = (λx. lookup t (Some x))"
proof -
  let ?f = "λz x. lookup t x * lookup (case x of None  0 | Some y  Poly_Mapping.single y 1) z"
  have "sum (?f z) (keys t) = lookup t (Some z)" for z
  proof (cases "Some z  keys t")
    case True
    hence "sum (?f z) (keys t) = sum (?f z) (insert (Some z) (keys t))"
      by (simp only: insert_absorb)
    also have " = lookup t (Some z) + sum (?f z) (keys t - {Some z})"
      by (simp add: sum.insert_remove)
    also have "sum (?f z) (keys t - {Some z}) = 0"
      by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
    finally show ?thesis by simp
  next
    case False
    hence "sum (?f z) (keys t) = 0"
      by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
    with False show ?thesis by (simp add: in_keys_iff)
  qed
  thus ?thesis by (auto simp: restrict_indets_pp_def restrict_indets_subst_def lookup_sum)
qed

lemma keys_restrict_indets_pp: "keys (restrict_indets_pp t) = the ` (keys t - {None})"
proof (rule set_eqI)
  fix x
  show "x  keys (restrict_indets_pp t)  x  the ` (keys t - {None})"
  proof
    assume "x  keys (restrict_indets_pp t)"
    hence "Some x  keys t" by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
    hence "Some x  keys t - {None}" by blast
    moreover have "x = the (Some x)" by simp
    ultimately show "x  the ` (keys t - {None})" by (rule rev_image_eqI)
  next
    assume "x  the ` (keys t - {None})"
    then obtain y where "y  keys t - {None}" and "x = the y" ..
    hence "Some x  keys t" by auto
    thus "x  keys (restrict_indets_pp t)"
      by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
  qed
qed

lemma subst_pp_restrict_indets_subst:
  "subst_pp (λx. monomial 1 (restrict_indets_subst x)) t = monomial 1 (restrict_indets_pp t)"
  by (simp add: subst_pp_def monomial_power_map_scale restrict_indets_pp_def flip: punit.monomial_prod_sum)

lemma restrict_indets_pp_zero [simp]: "restrict_indets_pp 0 = 0"
  by (simp add: restrict_indets_pp_def)

lemma restrict_indets_pp_plus: "restrict_indets_pp (s + t) = restrict_indets_pp s + restrict_indets_pp t"
  by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp)

lemma restrict_indets_pp_except_None [simp]:
  "restrict_indets_pp (except t {None}) = restrict_indets_pp t"
  by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp lookup_except)

lemma deg_pm_restrict_indets_pp: "deg_pm (restrict_indets_pp t) + lookup t None = deg_pm t"
proof -
  have "deg_pm t = sum (lookup t) (insert None (keys t))" by (rule deg_pm_superset) auto
  also from finite_keys have " = lookup t None + sum (lookup t) (keys t - {None})"
    by (rule sum.insert_remove)
  also have "sum (lookup t) (keys t - {None}) = (xkeys t. lookup t x * deg_pm (restrict_indets_subst x))"
    by (intro sum.mono_neutral_cong_left) (auto simp: restrict_indets_subst_def deg_pm_single)
  also have " = deg_pm (restrict_indets_pp t)"
    by (simp only: restrict_indets_pp_def deg_pm_sum deg_pm_map_scale)
  finally show ?thesis by simp
qed

lemma keys_restrict_indets_subset: "keys (restrict_indets p)  restrict_indets_pp ` keys p"
proof
  fix t
  assume "t  keys (restrict_indets p)"
  also have " = keys (tkeys p. monomial (lookup p t) (restrict_indets_pp t))"
    by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
  also have "  (tkeys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
    by (rule keys_sum_subset)
  also have " = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
  finally show "t  restrict_indets_pp ` keys p" .
qed

lemma keys_restrict_indets:
  assumes "None  indets p"
  shows "keys (restrict_indets p) = restrict_indets_pp ` keys p"
proof -
  have "keys (restrict_indets p) = keys (tkeys p. monomial (lookup p t) (restrict_indets_pp t))"
    by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
  also from finite_keys have " = (tkeys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
  proof (rule keys_sum)
    fix s t
    assume "s  keys p"
    hence "keys s  indets p" by (rule keys_subset_indets)
    with assms have "None  keys s" by blast
    assume "t  keys p"
    hence "keys t  indets p" by (rule keys_subset_indets)
    with assms have "None  keys t" by blast
    assume "s  t"
    then obtain x where neq: "lookup s x  lookup t x" by (meson poly_mapping_eqI)
    have "x  None"
    proof
      assume "x = None"
      with ‹None  keys s and ‹None  keys t have "x  keys s" and "x  keys t" by blast+
      with neq show False by (simp add: in_keys_iff)
    qed
    then obtain y where x: "x = Some y" by blast
    have "restrict_indets_pp t  restrict_indets_pp s"
    proof
      assume "restrict_indets_pp t = restrict_indets_pp s"
      hence "lookup (restrict_indets_pp t) y = lookup (restrict_indets_pp s) y" by (simp only:)
      hence "lookup s x = lookup t x" by (simp add: x lookup_restrict_indets_pp)
      with neq show False ..
    qed
    thus "keys (monomial (lookup p s) (restrict_indets_pp s)) 
          keys (monomial (lookup p t) (restrict_indets_pp t)) = {}"
      by (simp add: subst_pp_extend_indets_subst)
  qed
  also have " = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
  finally show ?thesis .
qed

lemma indets_restrict_indets_subset: "indets (restrict_indets p)  the ` (indets p - {None})"
proof
  fix x
  assume "x  indets (restrict_indets p)"
  then obtain t where "t  keys (restrict_indets p)" and "x  keys t" by (rule in_indetsE)
  from this(1) keys_restrict_indets_subset have "t  restrict_indets_pp ` keys p" ..
  then obtain s where "s  keys p" and "t = restrict_indets_pp s" ..
  from x  keys t this(2) have "x  the ` (keys s - {None})" by (simp only: keys_restrict_indets_pp)
  also from s  keys p have "  the ` (indets p - {None})"
    by (intro image_mono Diff_mono keys_subset_indets subset_refl)
  finally show "x  the ` (indets p - {None})" .
qed

lemma poly_deg_restrict_indets_le: "poly_deg (restrict_indets p)  poly_deg p"
proof (rule poly_deg_leI)
  fix t
  assume "t  keys (restrict_indets p)"
  hence "t  restrict_indets_pp ` keys p" using keys_restrict_indets_subset ..
  then obtain s where "s  keys p" and "t = restrict_indets_pp s" ..
  from this(2) have "deg_pm t + lookup s None = deg_pm s"
    by (simp only: deg_pm_restrict_indets_pp)
  also from s  keys p have "  poly_deg p" by (rule poly_deg_max_keys)
  finally show "deg_pm t  poly_deg p" by simp
qed

lemma
  shows restrict_indets_zero [simp]: "restrict_indets 0 = 0"
    and restrict_indets_one [simp]: "restrict_indets 1 = 1"
    and restrict_indets_monomial: "restrict_indets (monomial c t) = monomial c (restrict_indets_pp t)"
    and restrict_indets_plus: "restrict_indets (p + q) = restrict_indets p + restrict_indets q"
    and restrict_indets_uminus: "restrict_indets (- r) = - restrict_indets (r::_ 0 _::comm_ring_1)"
    and restrict_indets_minus: "restrict_indets (r - r') = restrict_indets r - restrict_indets r'"
    and restrict_indets_times: "restrict_indets (p * q) = restrict_indets p * restrict_indets q"
    and restrict_indets_power: "restrict_indets (p ^ n) = restrict_indets p ^ n"
    and restrict_indets_sum: "restrict_indets (sum f A) = (aA. restrict_indets (f a))"
    and restrict_indets_prod: "restrict_indets (prod f A) = (aA. restrict_indets (f a))"
  by (simp_all add: restrict_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
      poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod
      subst_pp_restrict_indets_subst punit.monom_mult_monomial)

lemma restrict_extend_indets [simp]: "restrict_indets (extend_indets p) = p"
  unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
  by (rule poly_subst_id)
    (simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)

lemma extend_restrict_indets:
  assumes "None  indets p"
  shows "extend_indets (restrict_indets p) = p"
  unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
proof (rule poly_subst_id)
  fix x
  assume "x  indets p"
  with assms have "x  None" by meson
  then obtain y where x: "x = Some y" by blast
  thus "poly_subst extend_indets_subst (monomial 1 (restrict_indets_subst x)) =
         monomial 1 (Poly_Mapping.single x 1)"
    by (simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)
qed

lemma restrict_indets_dehomogenize [simp]: "restrict_indets (dehomogenize None p) = restrict_indets p"
proof -
  have eq: "poly_subst (λx. (monomial 1 (restrict_indets_subst x))) (dehomo_subst None y) =
            monomial 1 (restrict_indets_subst y)" for y::"'x option"
    by (auto simp: restrict_indets_subst_def dehomo_subst_def poly_subst_monomial subst_pp_single)
  show ?thesis by (simp only: dehomogenize_def restrict_indets_def poly_subst_poly_subst eq) 
qed

corollary restrict_indets_comp_dehomogenize: "restrict_indets  dehomogenize None = restrict_indets"
  by (rule ext) (simp only: o_def restrict_indets_dehomogenize)

corollary extend_restrict_indets_eq_dehomogenize:
  "extend_indets (restrict_indets p) = dehomogenize None p"
proof -
  have "extend_indets (restrict_indets p) = extend_indets (restrict_indets (dehomogenize None p))"
    by simp
  also have " = dehomogenize None p"
  proof (intro extend_restrict_indets notI)
    assume "None  indets (dehomogenize None p)"
    hence "None  indets p - {None}" using indets_dehomogenize ..
    thus False by simp
  qed
  finally show ?thesis .
qed

corollary extend_indets_comp_restrict_indets: "extend_indets  restrict_indets = dehomogenize None"
  by (rule ext) (simp only: o_def extend_restrict_indets_eq_dehomogenize)

lemma restrict_homogenize_extend_indets [simp]:
  "restrict_indets (homogenize None (extend_indets p)) = p"
proof -
  have "restrict_indets (homogenize None (extend_indets p)) =
          restrict_indets (dehomogenize None (homogenize None (extend_indets p)))"
    by (simp only: restrict_indets_dehomogenize)
  also have " = restrict_indets (dehomogenize None (extend_indets p))"
    by (simp only: dehomogenize_homogenize)
  also have " = p" by simp
  finally show ?thesis .
qed

lemma dehomogenize_extend_indets [simp]: "dehomogenize None (extend_indets p) = extend_indets p"
  by (simp add: indets_extend_indets)

lemma restrict_indets_ideal: "restrict_indets ` ideal F = ideal (restrict_indets ` F)"
  using restrict_indets_plus restrict_indets_times
proof (rule image_ideal_eq_surj)
  from restrict_extend_indets show "surj restrict_indets" by (rule surjI)
qed

lemma ideal_restrict_indets:
  "ideal G = ideal (homogenize None ` extend_indets ` F)  ideal (restrict_indets ` G) = ideal F"
  by (simp flip: restrict_indets_ideal) (simp add: restrict_indets_ideal image_image)

lemma extend_indets_ideal: "extend_indets ` ideal F = ideal (extend_indets ` F)  P[- {None}]"
proof -
  have "extend_indets ` ideal F = extend_indets ` restrict_indets ` ideal (extend_indets ` F)"
    by (simp add: restrict_indets_ideal image_image)
  also have " = ideal (extend_indets ` F)  P[- {None}]"
    by (simp add: extend_restrict_indets_eq_dehomogenize dehomogenize_ideal image_image)
  finally show ?thesis .
qed

corollary extend_indets_ideal_subset: "extend_indets ` ideal F  ideal (extend_indets ` F)"
  by (simp add: extend_indets_ideal)

subsection ‹Canonical Isomorphisms between P[X,Y]› and P[X][Y]›: focus› and flatten›

definition focus :: "'x set  (('x 0 nat) 0 'a)  (('x 0 nat) 0 ('x 0 nat) 0 'a::comm_monoid_add)"
  where "focus X p = (tkeys p. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"

definition flatten :: "('a 0 'a 0 'b)  ('a::comm_powerprod 0 'b::semiring_1)"
  where "flatten p = (tkeys p. punit.monom_mult 1 t (lookup p t))"

lemma focus_superset:
  assumes "finite A" and "keys p  A"
  shows "focus X p = (tA. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"
  unfolding focus_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)

lemma keys_focus: "keys (focus X p) = (λt. except t (- X)) ` keys p"
proof
  have "keys (focus X p)  (tkeys p. keys (monomial (monomial (lookup p t) (except t X)) (except t (- X))))"
    unfolding focus_def by (rule keys_sum_subset)
  also have "  (tkeys p. {except t (- X)})" by (intro UN_mono subset_refl) simp
  also have " = (λt. except t (- X)) ` keys p" by (rule UNION_singleton_eq_range)
  finally show "keys (focus X p)  (λt. except t (- X)) ` keys p" .
next
  {
    fix s
    assume "s  keys p"
    have "lookup (focus X p) (except s (- X)) =
              (tkeys p. monomial (lookup p t) (except t X) when except t (- X) = except s (- X))"
      (is "_ = ?p")
      by (simp only: focus_def lookup_sum lookup_single)
    also have "  0"
    proof
      have "lookup ?p (except s X) =
              (tkeys p. lookup p t when except t X = except s X  except t (- X) = except s (- X))"
        by (simp add: lookup_sum lookup_single when_def if_distrib if_distribR)
            (metis (no_types, hide_lams) lookup_single_eq lookup_single_not_eq lookup_zero)
      also have " = (t{s}. lookup p t)"
      proof (intro sum.mono_neutral_cong_right ballI)
        fix t
        assume "t  keys p - {s}"
        hence "t  s" by simp
        hence "except t X + except t (- X)  except s X + except s (- X)"
          by (simp flip: except_decomp)
        thus "(lookup p t when except t X = except s X  except t (- X) = except s (- X)) = 0"
          by (auto simp: when_def)
      next
        from s  keys p show "{s}  keys p" by simp
      qed simp_all
      also from s  keys p have "  0" by (simp add: in_keys_iff)
      finally have "except s X  keys ?p" by (simp add: in_keys_iff)
      moreover assume "?p = 0"
      ultimately show False by simp
    qed
    finally have "except s (- X)  keys (focus X p)" by (simp add: in_keys_iff)
  }
  thus "(λt. except t (- X)) ` keys p  keys (focus X p)" by blast
qed

lemma keys_coeffs_focus_subset:
  assumes "c  range (lookup (focus X p))"
  shows "keys c  (λt. except t X) ` keys p"
proof -
  from assms obtain s where "c = lookup (focus X p) s" ..
  hence "keys c = keys (lookup (focus X p) s)" by (simp only:)
  also have "  (tkeys p. keys (lookup (monomial (monomial (lookup p t) (except t X)) (except t (- X))) s))"
    unfolding focus_def lookup_sum by (rule keys_sum_subset)
  also from subset_refl have "  (tkeys p. {except t X})"
    by (rule UN_mono) (simp add: lookup_single when_def)
  also have " = (λt. except t X) ` keys p" by (rule UNION_singleton_eq_range)
  finally show ?thesis .
qed

lemma focus_in_Polys':
  assumes "p  P[Y]"
  shows "focus X p  P[Y  X]"
proof (intro PolysI subsetI)
  fix t
  assume "t  keys (focus X p)"
  then obtain s where "s  keys p" and t: "t = except s (- X)" unfolding keys_focus ..
  note this(1)
  also from assms have "keys p  .[Y]" by (rule PolysD)
  finally have "keys s  Y" by (rule PPsD)
  hence "keys t  Y  X" by (simp add: t keys_except le_infI1)
  thus "t  .[Y  X]" by (rule PPsI)
qed

corollary focus_in_Polys: "focus X p  P[X]"
proof -
  have "p  P[UNIV]" by simp
  hence "focus X p  P[UNIV  X]" by (rule focus_in_Polys')
  thus ?thesis by simp
qed

lemma focus_coeffs_subset_Polys':
  assumes "p  P[Y]"
  shows "range (lookup (focus X p))  P[Y - X]"
proof (intro subsetI PolysI)
  fix c t
  assume "c  range (lookup (focus X p))"
  hence "keys c  (λt. except t X) ` keys p" by (rule keys_coeffs_focus_subset)
  moreover assume "t  keys c"
  ultimately have "t  (λt. except t X) ` keys p" ..
  then obtain s where "s  keys p" and t: "t = except s X" ..
  note this(1)
  also from assms have "keys p  .[Y]" by (rule PolysD)
  finally have "keys s  Y" by (rule PPsD)
  hence "keys t  Y - X" by (simp add: t keys_except Diff_mono)
  thus "t  .[Y - X]" by (rule PPsI)
qed

corollary focus_coeffs_subset_Polys: "range (lookup (focus X p))  P[- X]"
proof -
  have "p  P[UNIV]" by simp
  hence "range (lookup (focus X p))  P[UNIV - X]" by (rule focus_coeffs_subset_Polys')
  thus ?thesis by (simp only: Compl_eq_Diff_UNIV)
qed

corollary lookup_focus_in_Polys: "lookup (focus X p) t  P[- X]"
  using focus_coeffs_subset_Polys by blast

lemma focus_zero [simp]: "focus X 0 = 0"
  by (simp add: focus_def)

lemma focus_eq_zero_iff [iff]: "focus X p = 0  p = 0"
  by (simp only: keys_focus flip: keys_eq_empty_iff) simp

lemma focus_one [simp]: "focus X 1 = 1"
  by (simp add: focus_def)

lemma focus_monomial: "focus X (monomial c t) = monomial (monomial c (except t X)) (except t (- X))"
  by (simp add: focus_def)

lemma focus_uminus [simp]: "focus X (- p) = - focus X p"
  by (simp add: focus_def keys_uminus single_uminus sum_negf)

lemma focus_plus: "focus X (p + q) = focus X p + focus X q"
proof -
  have "finite (keys p  keys q)" by simp
  moreover have "keys (p + q)  keys p  keys q" by (rule Poly_Mapping.keys_add)
  ultimately show ?thesis
    by (simp add: focus_superset[where A="keys p  keys q"] lookup_add single_add sum.distrib)
qed

lemma focus_minus: "focus X (p - q) = focus X p - focus X (q::_ 0 _::ab_group_add)"
  by (simp only: diff_conv_add_uminus focus_plus focus_uminus)

lemma focus_times: "focus X (p * q) = focus X p * focus X q"
proof -
  have eq: "focus X (monomial c s * q) = focus X (monomial c s) * focus X q" for c s
  proof -
    have "focus X (monomial c s * q) = focus X (punit.monom_mult c s q)"
      by (simp only: times_monomial_left)
    also have " = (t(+) s ` keys q. monomial (monomial (lookup (punit.monom_mult c s q) t)
                                            (except t X)) (except t (- X)))"
      by (rule focus_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
    also have " = (tkeys q. ((λt. monomial (monomial (lookup (punit.monom_mult c s q) t)
                                  (except t X)) (except t (- X)))  ((+) s)) t)"
      by (rule sum.reindex) simp
    also have " = monomial (monomial c (except s X)) (except s (- X)) *
                      (tkeys q. monomial (monomial (lookup q t) (except t X)) (except t (- X)))"
      by (simp add: o_def punit.lookup_monom_mult except_plus times_monomial_monomial sum_distrib_left)
    also have " = focus X (monomial c s) * focus X q"
      by (simp only: focus_monomial focus_def[where p=q])
    finally show ?thesis .
  qed
  show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs focus_plus eq)
qed

lemma focus_sum: "focus X (sum f I) = (iI. focus X (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: focus_plus)

lemma focus_prod: "focus X (prod f I) = (iI. focus X (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: focus_times)

lemma focus_power [simp]: "focus X (f ^ m) = focus X f ^ m"
  by (induct m) (simp_all add: focus_times)

lemma focus_Polys:
  assumes "p  P[X]"
  shows "focus X p = (tkeys p. monomial (monomial (lookup p t) 0) t)"
  unfolding focus_def
proof (rule sum.cong)
  fix t
  assume "t  keys p"
  also from assms have "  .[X]" by (rule PolysD)
  finally have "keys t  X" by (rule PPsD)
  hence "except t X = 0" and "except t (- X) = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
  thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
        monomial (monomial (lookup p t) 0) t" by simp
qed (fact refl)

corollary lookup_focus_Polys: "p  P[X]  lookup (focus X p) t = monomial (lookup p t) 0"
  by (simp add: focus_Polys lookup_sum lookup_single when_def in_keys_iff)

lemma focus_Polys_Compl:
  assumes "p  P[- X]"
  shows "focus X p = monomial p 0"
proof -
  have "focus X p = (tkeys p. monomial (monomial (lookup p t) t) 0)" unfolding focus_def
  proof (rule sum.cong)
    fix t
    assume "t  keys p"
    also from assms have "  .[- X]" by (rule PolysD)
    finally have "keys t  - X" by (rule PPsD)
    hence "except t (- X) = 0" and "except t X = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
    thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
          monomial (monomial (lookup p t) t) 0" by simp
  qed (fact refl)
  also have " = monomial (tkeys p. monomial (lookup p t) t) 0" by (simp only: monomial_sum)
  also have " = monomial p 0" by (simp only: poly_mapping_sum_monomials)
  finally show ?thesis .
qed

corollary focus_empty [simp]: "focus {} p = monomial p 0"
  by (rule focus_Polys_Compl) simp

lemma focus_Int:
  assumes "p  P[Y]"
  shows "focus (X  Y) p = focus X p"
  unfolding focus_def using refl
proof (rule sum.cong)
  fix t
  assume "t  keys p"
  also from assms have "  .[Y]" by (rule PolysD)
  finally have "keys t  Y" by (rule PPsD)
  hence "keys t  X  Y" by blast
  hence "except t (X  Y) = except t X + except t Y" by (rule except_Int)
  also from ‹keys t  Y have "except t Y = 0" by (rule except_eq_zeroI)
  finally have eq: "except t (X  Y) = except t X" by simp
  have "except t (- (X  Y)) = except (except t (- Y)) (- X)" by (simp add: except_except Un_commute)
  also from ‹keys t  Y have "except t (- Y) = t" by (auto simp: except_id_iff)
  finally show "monomial (monomial (lookup p t) (except t (X  Y))) (except t (- (X  Y))) =
                monomial (monomial (lookup p t) (except t X)) (except t (- X))" by (simp only: eq)
qed

lemma range_focusD:
  assumes "p  range (focus X)"
  shows "p  P[X]" and "range (lookup p)  P[- X]" and "lookup p t  P[- X]"
  using assms by (auto intro: focus_in_Polys lookup_focus_in_Polys)

lemma range_focusI:
  assumes "p  P[X]" and "lookup p ` keys (p::_ 0 _ 0 _::semiring_1)  P[- X]"
  shows "p  range (focus X)"
  using assms
proof (induct p rule: poly_mapping_plus_induct_Polys)
  case 0
  show ?case by simp
next
  case (plus p c t)
  from plus.hyps(3) have 1: "keys (monomial c t) = {t}" by simp
  also from plus.hyps(4) have "  keys p = {}" by simp
  finally have "keys (monomial c t + p) = keys (monomial c t)  keys p" by (rule keys_add[symmetric])
  hence 2: "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
  from t  .[X] have "keys t  X" by (rule PPsD)
  hence eq1: "except t X = 0" and eq2: "except t (- X) = t"
    by (rule except_eq_zeroI, auto simp: except_id_iff)
  from plus.hyps(3, 4) plus.prems have "c  P[- X]" and "lookup p ` keys p  P[- X]"
    by (simp_all add: 2 lookup_add lookup_single in_keys_iff)
        (smt add.commute add.right_neutral image_cong plus.hyps(4) when_simps(2))
  from this(2) have "p  range (focus X)" by (rule plus.hyps)
  then obtain q where p: "p = focus X q" ..
  moreover from c  P[- X] have "monomial c t = focus X (monomial 1 t * c)"
    by (simp add: focus_times focus_monomial eq1 eq2 focus_Polys_Compl times_monomial_monomial)
  ultimately have "monomial c t + p = focus X (monomial 1 t * c + q)" by (simp only: focus_plus)
  thus ?case by (rule range_eqI)
qed

lemma inj_focus: "inj ((focus X) :: (('x 0 nat) 0 'a::ab_group_add)  _)"
proof (rule injI)
  fix p q :: "('x 0 nat) 0 'a"
  assume "focus X p = focus X q"
  hence "focus X (p - q) = 0" by (simp add: focus_minus)
  thus "p = q" by simp
qed

lemma flatten_superset:
  assumes "finite A" and "keys p  A"
  shows "flatten p = (tA. punit.monom_mult 1 t (lookup p t))"
  unfolding flatten_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)

lemma keys_flatten_subset: "keys (flatten p)  (tkeys p. (+) t ` keys (lookup p t))"
proof -
  have "keys (flatten p)  (tkeys p. keys (punit.monom_mult 1 t (lookup p t)))"
    unfolding flatten_def by (rule keys_sum_subset)
  also from subset_refl have "  (tkeys p. (+) t ` keys (lookup p t))"
    by (rule UN_mono) (rule punit.keys_monom_mult_subset[simplified])
  finally show ?thesis .
qed

lemma flatten_in_Polys:
  assumes "p  P[X]" and "lookup p ` keys p  P[Y]"
  shows "flatten p  P[X  Y]"
proof (intro PolysI subsetI)
  fix t
  assume "t  keys (flatten p)"
  also have "  (tkeys p. (+) t ` keys (lookup p t))" by (rule keys_flatten_subset)
  finally obtain s where "s  keys p" and "t  (+) s ` keys (lookup p s)" ..
  from this(2) obtain s' where "s'  keys (lookup p s)" and t: "t = s + s'" ..
  from assms(1) have "keys p  .[X]" by (rule PolysD)
  with s  keys p have "s  .[X]" ..
  also have "  .[X  Y]" by (rule PPs_mono) simp
  finally have 1: "s  .[X  Y]" .
  from s  keys p have "lookup p s  lookup p ` keys p" by (rule imageI)
  also have "  P[Y]" by fact
  finally have "keys (lookup p s)  .[Y]" by (rule PolysD)
  with s'  _ have "s'  .[Y]" ..
  also have "  .[X  Y]" by (rule PPs_mono) simp
  finally have "s'  .[X  Y]" .
  with 1 show "t  .[X  Y]" unfolding t by (rule PPs_closed_plus)
qed

lemma flatten_zero [simp]: "flatten 0 = 0"
  by (simp add: flatten_def)

lemma flatten_one [simp]: "flatten 1 = 1"
  by (simp add: flatten_def)

lemma flatten_monomial: "flatten (monomial c t) = punit.monom_mult 1 t c"
  by (simp add: flatten_def)

lemma flatten_uminus [simp]: "flatten (- p) = - flatten (p::_ 0 _ 0 _::ring)"
  by (simp add: flatten_def keys_uminus punit.monom_mult_uminus_right sum_negf)

lemma flatten_plus: "flatten (p + q) = flatten p + flatten q"
proof -
  have "finite (keys p  keys q)" by simp
  moreover have "keys (p + q)  keys p  keys q" by (rule Poly_Mapping.keys_add)
  ultimately show ?thesis
    by (simp add: flatten_superset[where A="keys p  keys q"] punit.monom_mult_dist_right lookup_add
                  sum.distrib)
qed

lemma flatten_minus: "flatten (p - q) = flatten p - flatten (q::_ 0 _ 0 _::ring)"
  by (simp only: diff_conv_add_uminus flatten_plus flatten_uminus)

lemma flatten_times: "flatten (p * q) = flatten p * flatten (q::_ 0 _ 0 'b::comm_semiring_1)"
proof -
  have eq: "flatten (monomial c s * q) = flatten (monomial c s) * flatten q" for c s
  proof -
    have eq: "monomial 1 (t + s) = monomial 1 s * monomial (1::'b) t" for t
      by (simp add: times_monomial_monomial add.commute)
    have "flatten (monomial c s * q) = flatten (punit.monom_mult c s q)"
      by (simp only: times_monomial_left)
    also have " = (t(+) s ` keys q. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t))"
      by (rule flatten_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
    also have " = (tkeys q. ((λt. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t))  (+) s) t)"
      by (rule sum.reindex) simp
    thm times_monomial_left
    also have " = punit.monom_mult 1 s c *
                      (tkeys q. punit.monom_mult 1 t (lookup q t))"
      by (simp add: o_def punit.lookup_monom_mult sum_distrib_left)
          (simp add: algebra_simps eq flip: times_monomial_left)
    also have " = flatten (monomial c s) * flatten q"
      by (simp only: flatten_monomial flatten_def[where p=q])
    finally show ?thesis .
  qed
  show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs flatten_plus eq)
qed

lemma flatten_monom_mult:
  "flatten (punit.monom_mult c t p) = punit.monom_mult 1 t (c * flatten (p::_ 0 _ 0 'b::comm_semiring_1))"
  by (simp only: flatten_times flatten_monomial mult.assoc flip: times_monomial_left)

lemma flatten_sum: "flatten (sum f I) = (iI. flatten (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: flatten_plus)

lemma flatten_prod: "flatten (prod f I) = (iI. flatten (f i :: _ 0 _::comm_semiring_1))"
  by (induct I rule: infinite_finite_induct) (simp_all add: flatten_times)

lemma flatten_power [simp]: "flatten (f ^ m) = flatten (f:: _ 0 _::comm_semiring_1) ^ m"
  by (induct m) (simp_all add: flatten_times)

lemma surj_flatten: "surj flatten"
proof (rule surjI)
  fix p
  show "flatten (monomial p 0) = p" by (simp add: flatten_monomial)
qed

lemma flatten_focus [simp]: "flatten (focus X p) = p"
  by (induct p rule: poly_mapping_plus_induct)
      (simp_all add: focus_plus flatten_plus focus_monomial flatten_monomial
                      punit.monom_mult_monomial add.commute flip: except_decomp)

lemma focus_flatten:
  assumes "p  P[X]" and "lookup p ` keys p  P[- X]"
  shows "focus X (flatten p) = p"
proof -
  from assms have "p  range (focus X)" by (rule range_focusI)
  then obtain q where "p = focus X q" ..
  thus ?thesis by simp
qed

lemma image_focus_ideal: "focus X ` ideal F = ideal (focus X ` F)  range (focus X)"
proof
  from focus_plus focus_times have "focus X ` ideal F  ideal (focus X ` F)"
    by (rule image_ideal_subset)
  moreover from subset_UNIV have "focus X ` ideal F  range (focus X)" by (rule image_mono)
  ultimately show "focus X ` ideal F  ideal (focus X ` F)  range (focus X)" by blast
next
  show "ideal (focus X ` F)  range (focus X)  focus X ` ideal F"
  proof
    fix p
    assume "p  ideal (focus X ` F)  range (focus X)"
    hence "p  ideal (focus X ` F)" and "p  range (focus X)" by simp_all
    from this(1) obtain F0 q where "F0  focus X ` F" and p: "p = (f'F0. q f' * f')"
      by (rule ideal.spanE)
    from this(1) obtain F' where "F'  F" and F0: "F0 = focus X ` F'" by (rule subset_imageE)
    from inj_focus subset_UNIV have "inj_on (focus X) F'" by (rule inj_on_subset)
    from p  range _ obtain p' where "p = focus X p'" ..
    hence "p = focus X (flatten p)" by simp
    also from ‹inj_on _ F' have " = focus X (f'F'. flatten (q (focus X f')) * f')"
      by (simp add: p F0 sum.reindex flatten_sum flatten_times)
    finally have "p = focus X (f'F'. flatten (q (focus X f')) * f')" .
    moreover have "(f'F'. flatten (q (focus X f')) * f')  ideal F"
    proof
      show "(f'F'. flatten (q (focus X f')) * f')  ideal F'" by (rule ideal.sum_in_spanI)
    next
      from F'  F show "ideal F'  ideal F" by (rule ideal.span_mono)
    qed
    ultimately show "p  focus X ` ideal F" by (rule image_eqI)
  qed
qed

lemma image_flatten_ideal: "flatten ` ideal F = ideal (flatten ` F)"
  using flatten_plus flatten_times surj_flatten by (rule image_ideal_eq_surj)

lemma poly_eval_focus:
  "poly_eval a (focus X p) = poly_subst (λx. if x  X then a x else monomial 1 (Poly_Mapping.single x 1)) p"
proof -
  let ?b = "λx. if x  X then a x else monomial 1 (Poly_Mapping.single x 1)"
  have *: "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
              (subst_pp (λx. monomial (a x) 0) (except t (- X)))) 0 =
            punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" for t
  proof -
    have 1: "subst_pp ?b (except t X) = monomial 1 (except t X)"
      by (rule subst_pp_id) (simp add: keys_except)
    from refl have 2: "subst_pp ?b (except t (- X)) = subst_pp a (except t (-X))"
      by (rule subst_pp_cong) (simp add: keys_except)
    have "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
                      (subst_pp (λx. monomial (a x) 0) (except t (- X)))) 0 =
          punit.monom_mult (lookup p t) (except t X) (subst_pp a (except t (- X)))"
      by (simp add: lookup_times_zero subst_pp_def lookup_prod_zero lookup_power_zero
                flip: times_monomial_left)
    also have " = punit.monom_mult (lookup p t) 0 (monomial 1 (except t X) * subst_pp a (except t (- X)))"
      by (simp add: times_monomial_monomial flip: times_monomial_left mult.assoc)
    also have " = punit.monom_mult (lookup p t) 0 (subst_pp ?b (except t X + except t (- X)))"
      by (simp only: subst_pp_plus 1 2)
    also have " = punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" by (simp flip: except_decomp)
    finally show ?thesis .
  qed
  show ?thesis by (simp add: poly_eval_def focus_def poly_subst_sum lookup_sum poly_subst_monomial *
                        flip: poly_subst_def)
qed

corollary poly_eval_poly_eval_focus:
  "poly_eval a (poly_eval b (focus X p)) = poly_eval (λx::'x. if x  X then poly_eval a (b x) else a x) p"
proof -
  have eq: "monomial (lookup (poly_subst (λy. monomial (a y) (0::'x 0 nat)) q) 0) 0 =
              poly_subst (λy. monomial (a y) (0::'x 0 nat)) q" for q
    by (intro poly_deg_zero_imp_monomial poly_deg_poly_subst_eq_zeroI) simp
  show ?thesis unfolding poly_eval_focus
    by (simp add: poly_eval_def poly_subst_poly_subst if_distrib poly_subst_monomial subst_pp_single eq
            cong: if_cong)
qed

lemma indets_poly_eval_focus_subset:
  "indets (poly_eval a (focus X p))   (indets ` a ` X)  (indets p - X)"
proof
  fix x
  assume "x  indets (poly_eval a (focus X p))"
  also have " = indets (poly_subst (λx. if x  X then a x else monomial 1 (Poly_Mapping.single x 1)) p)"
    (is "_ = indets (poly_subst ?f _)") by (simp only: poly_eval_focus)
  finally obtain y where "y  indets p" and "x  indets (?f y)" by (rule in_indets_poly_substE)
  from this(2) have "(x  X  x = y)  (y  X  x  indets (a y))"
    by (simp add: indets_monomial split: if_split_asm)
  thus "x   (indets ` a ` X)  (indets p - X)"
  proof (elim disjE conjE)
    assume "x  X" and "x = y"
    with y  indets p have "x  indets p - X" by simp
    thus ?thesis ..
  next
    assume "y  X" and "x  indets (a y)"
    hence "x   (indets ` a ` X)" by blast
    thus ?thesis ..
  qed
qed

lemma lookup_poly_eval_focus:
  "lookup (poly_eval (λx. monomial (a x) 0) (focus X p)) t = poly_eval a (lookup (focus (- X) p) t)"
proof -
  let ?f = "λx. if x  X then monomial (a x) 0 else monomial 1 (Poly_Mapping.single x 1)"
  have eq: "subst_pp ?f s = monomial (xkeys s  X. a x ^ lookup s x) (except s X)" for s
  proof -
    have "subst_pp ?f s = (x(keys s  X)  (keys s - X). ?f x ^ lookup s x)"
      unfolding subst_pp_def by (rule prod.cong) blast+
    also have " = (xkeys s  X. ?f x ^ lookup s x) * (xkeys s - X. ?f x ^ lookup s x)"
      by (rule prod.union_disjoint) auto
    also have " = monomial (xkeys s  X. a x ^ lookup s x)
                              (xkeys s - X. Poly_Mapping.single x (lookup s x))"
      by (simp add: monomial_power_map_scale times_monomial_monomial flip: punit.monomial_prod_sum)
    also have "(xkeys s - X. Poly_Mapping.single x (lookup s x)) = except s X"
      by (metis (mono_tags, lifting) DiffD2 keys_except lookup_except_eq_idI
              poly_mapping_sum_monomials sum.cong)
    finally show ?thesis .
  qed
  show ?thesis
    by (simp add: poly_eval_focus poly_subst_def lookup_sum eq flip: punit.map_scale_eq_monom_mult)
       (simp add: focus_def lookup_sum poly_eval_sum lookup_single when_distrib poly_eval_monomial
                  keys_except lookup_except_when)
qed

lemma keys_poly_eval_focus_subset:
  "keys (poly_eval (λx. monomial (a x) 0) (focus X p))  (λt. except t X) ` keys p"
proof
  fix t
  assume "t  keys (poly_eval (λx. monomial (a x) 0) (focus X p))"
  hence "lookup (poly_eval (λx. monomial (a x) 0) (focus X p)) t  0" by (simp add: in_keys_iff)
  hence "poly_eval a (lookup (focus (- X) p) t)  0" by (simp add: lookup_poly_eval_focus)
  hence "t  keys (focus (- X) p)" by (auto simp flip: lookup_not_eq_zero_eq_in_keys)
  thus "t  (λt. except t X) ` keys p" by (simp add: keys_focus)
qed

lemma poly_eval_focus_in_Polys:
  assumes "p  P[X]"
  shows "poly_eval (λx. monomial (a x) 0) (focus Y p)  P[X - Y]"
proof (rule PolysI_alt)
  have "indets (poly_eval (λx. monomial (a x) 0) (focus Y p)) 
           (indets ` (λx. monomial (a x) 0) ` Y)  (indets p - Y)"
    by (fact indets_poly_eval_focus_subset)
  also have " = indets p - Y" by simp
  also from assms have "  X - Y" by (auto dest: PolysD)
  finally show "indets (poly_eval (λx. monomial (a x) 0) (focus Y p))  X - Y" .
qed

lemma image_poly_eval_focus_ideal:
  "poly_eval (λx. monomial (a x) 0) ` focus X ` ideal F =
    ideal (poly_eval (λx. monomial (a x) 0) ` focus X ` F) 
      (P[- X]::(('x 0 nat) 0 'a::comm_ring_1) set)"
proof -
  let ?h = "λf. poly_eval (λx. monomial (a x) 0) (focus X f)"
  have h_id: "?h p = p" if "p  P[- X]" for p
  proof -
    from that have "focus X p  P[- X  X]" by (rule focus_in_Polys')
    also have " = P[{}]" by simp
    finally obtain c where eq: "focus X p = monomial c 0" unfolding Polys_empty ..
    hence "flatten (focus X p) = flatten (monomial c 0)" by (rule arg_cong)
    hence "c = p" by (simp add: flatten_monomial)
    thus "?h p = p" by (simp add: eq poly_eval_monomial)
  qed
  have rng: "range ?h = P[- X]"
  proof (intro subset_antisym subsetI, elim rangeE)
    fix b f
    assume b: "b = ?h f"
    have "?h f  P[UNIV - X]" by (rule poly_eval_focus_in_Polys) simp
    thus "b  P[- X]" by (simp add: b Compl_eq_Diff_UNIV)
  next
    fix p :: "('x 0 nat) 0 'a"
    assume "p  P[- X]"
    hence "?h p = p" by (rule h_id)
    hence "p = ?h p" by (rule sym)
    thus "p  range ?h" by (rule range_eqI)
  qed
  have "poly_eval (λx. monomial (a x) 0) ` focus X ` ideal F = ?h ` ideal F" by (fact image_image)
  also have " = ideal (?h ` F)  range ?h"
  proof (rule image_ideal_eq_Int)
    fix p
    have "?h p  range ?h" by (fact rangeI)
    also have " = P[- X]" by fact
    finally show "?h (?h p) = ?h p" by (rule h_id)
  qed (simp_all only: focus_plus poly_eval_plus focus_times poly_eval_times)
  also have " = ideal (poly_eval (λx. monomial (a x) 0) ` focus X ` F)  P[- X]"
    by (simp only: image_image rng)
  finally show ?thesis .
qed

subsection ‹Locale @{term pm_powerprod}

lemma varnum_eq_zero_iff: "varnum X t = 0  t  .[X]"
  by (auto simp: varnum_def PPs_def)

lemma dgrad_set_varnum: "dgrad_set (varnum X) 0 = .[X]"
  by (simp add: dgrad_set_def PPs_def varnum_eq_zero_iff)

context ordered_powerprod
begin

abbreviation "lcf  punit.lc"
abbreviation "tcf  punit.tc"
abbreviation "lpp  punit.lt"
abbreviation "tpp  punit.tt"

end (* ordered_powerprod *)

locale pm_powerprod =
  ordered_powerprod ord ord_strict
  for ord::"('x::{countable,linorder} 0 nat)  ('x 0 nat)  bool" (infixl "" 50)
  and ord_strict (infixl "" 50)
begin

sublocale gd_powerprod ..

lemma PPs_closed_lpp:
  assumes "p  P[X]"
  shows "lpp p  .[X]"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: zero_in_PPs)
next
  case False
  hence "lpp p  keys p" by (rule punit.lt_in_keys)
  also from assms have "  .[X]" by (rule PolysD)
  finally show ?thesis .
qed

lemma PPs_closed_tpp:
  assumes "p  P[X]"
  shows "tpp p  .[X]"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: zero_in_PPs)
next
  case False
  hence "tpp p  keys p" by (rule punit.tt_in_keys)
  also from assms have "  .[X]" by (rule PolysD)
  finally show ?thesis .
qed

corollary PPs_closed_image_lpp: "F  P[X]  lpp ` F  .[X]"
  by (auto intro: PPs_closed_lpp)

corollary PPs_closed_image_tpp: "F  P[X]  tpp ` F  .[X]"
  by (auto intro: PPs_closed_tpp)

lemma hom_component_lpp:
  assumes "p  0"
  shows "hom_component p (deg_pm (lpp p))  0" (is "?p  0")
    and "lpp (hom_component p (deg_pm (lpp p))) = lpp p"
proof -
  from assms have "lpp p  keys p" by (rule punit.lt_in_keys)
  hence *: "lpp p  keys ?p" by (simp add: keys_hom_component)
  thus "?p  0" by auto

  from * show "lpp ?p = lpp p"
  proof (rule punit.lt_eqI_keys)
    fix t
    assume "t  keys ?p"
    hence "t  keys p" by (simp add: keys_hom_component)
    thus "t  lpp p" by (rule punit.lt_max_keys)
  qed
qed

definition is_hom_ord :: "'x  bool"
  where "is_hom_ord x  (s t. deg_pm s = deg_pm t  (s  t  except s {x}  except t {x}))"

lemma is_hom_ordD: "is_hom_ord x  deg_pm s = deg_pm t  s  t  except s {x}  except t {x}"
  by (simp add: is_hom_ord_def)

lemma dgrad_p_set_varnum: "punit.dgrad_p_set (varnum X) 0 = P[X]"
  by (simp add: punit.dgrad_p_set_def dgrad_set_varnum Polys_def)

end

text ‹We must create a copy of @{locale pm_powerprod} to avoid infinite chains of interpretations.›

instantiation option :: (linorder) linorder
begin

fun less_eq_option :: "'a option  'a option  bool" where
  "less_eq_option None _ = True" |
  "less_eq_option (Some x) None = False" |
  "less_eq_option (Some x) (Some y) = (x  y)"

definition less_option :: "'a option  'a option  bool"
  where "less_option x y  x  y  ¬ y  x"

instance proof
  fix x :: "'a option"
  show "x  x" using less_eq_option.elims(3) by fastforce
qed (auto simp: less_option_def elim!: less_eq_option.elims)

end

locale extended_ord_pm_powerprod = pm_powerprod
begin

definition extended_ord :: "('a option 0 nat)  ('a option 0 nat)  bool"
  where "extended_ord s t  (restrict_indets_pp s  restrict_indets_pp t 
                          (restrict_indets_pp s = restrict_indets_pp t  lookup s None  lookup t None))"

definition extended_ord_strict :: "('a option 0 nat)  ('a option 0 nat)  bool"
  where "extended_ord_strict s t  (restrict_indets_pp s  restrict_indets_pp t 
                          (restrict_indets_pp s = restrict_indets_pp t  lookup s None < lookup t None))"

sublocale extended_ord: pm_powerprod extended_ord extended_ord_strict
proof -
  have 1: "s = t" if "lookup s None = lookup t None" and "restrict_indets_pp s = restrict_indets_pp t"
    for s t :: "'a option 0 nat"
  proof (rule poly_mapping_eqI)
    fix y
    show "lookup s y = lookup t y"
    proof (cases y)
      case None
      with that(1) show ?thesis by simp
    next
      case y: (Some z)
      have "lookup s y = lookup (restrict_indets_pp s) z" by (simp only: lookup_restrict_indets_pp y)
      also have " = lookup (restrict_indets_pp t) z" by (simp only: that(2))
      also have " = lookup t y" by (simp only: lookup_restrict_indets_pp y)
      finally show ?thesis .
    qed
  qed
  have 2: "0  t" if "t  0" for t::"'a 0 nat"
    using that zero_min by (rule ordered_powerprod_lin.dual_order.not_eq_order_implies_strict)
  show "pm_powerprod extended_ord extended_ord_strict"
    by standard (auto simp: extended_ord_def extended_ord_strict_def restrict_indets_pp_plus lookup_add 1
                  dest: plus_monotone_strict 2)
qed

lemma extended_ord_is_hom_ord: "extended_ord.is_hom_ord None"
  by (auto simp add: extended_ord_def lookup_restrict_indets_pp lookup_except extended_ord.is_hom_ord_def
            simp flip: deg_pm_restrict_indets_pp)

end

end (* theory *)

Theory MPoly_Type_Univariate

(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
theory MPoly_Type_Univariate
  imports
    More_MPoly_Type
    "HOL-Computational_Algebra.Polynomial"
begin

text ‹This file connects univariate MPolys to the theory of univariate polynomials from
  @{theory "HOL-Computational_Algebra.Polynomial"}.›

definition poly_to_mpoly::"nat  'a::comm_monoid_add poly  'a mpoly"
where "poly_to_mpoly v p = MPoly (Abs_poly_mapping (λm. (coeff p (Poly_Mapping.lookup m v)) when Poly_Mapping.keys m  {v}))"

lemma poly_to_mpoly_finite: "finite {m::nat 0 nat. (coeff p (Poly_Mapping.lookup m v) when Poly_Mapping.keys m  {v})  0}" (is "finite ?M")
proof -
  have "?M  Poly_Mapping.single v ` {x. Polynomial.coeff p x  0}"
  proof
    fix m assume "m  ?M"
    then have "v'. v'v  Poly_Mapping.lookup m v' = 0" by (fastforce simp add: in_keys_iff)
    then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
      using Poly_Mapping.poly_mapping_eqI by (metis (full_types) lookup_single_eq lookup_single_not_eq)
    then show "m  (Poly_Mapping.single v) ` {x. Polynomial.coeff p x  0}" using m  ?M by auto
  qed
  then show ?thesis using finite_surj[OF MOST_coeff_eq_0[unfolded eventually_cofinite]] by blast
qed

lemma coeff_poly_to_mpoly: "MPoly_Type.coeff (poly_to_mpoly v p) (Poly_Mapping.single v k) = Polynomial.coeff p k"
  unfolding poly_to_mpoly_def coeff_def MPoly_inverse[OF Set.UNIV_I] lookup_Abs_poly_mapping[OF poly_to_mpoly_finite]
  using empty_subsetI keys_single lookup_single order_refl when_simps(1) by simp

definition mpoly_to_poly::"nat  'a::comm_monoid_add mpoly  'a poly"
where "mpoly_to_poly v p = Abs_poly (λk. MPoly_Type.coeff p (Poly_Mapping.single v k))"

lemma coeff_mpoly_to_poly[simp]: "Polynomial.coeff (mpoly_to_poly v p) k = MPoly_Type.coeff p (Poly_Mapping.single v k)"
proof -
  have 0:"Poly_Mapping.single v ` {x. Poly_Mapping.lookup (mapping_of p) (Poly_Mapping.single v x)  0}
           {k. Poly_Mapping.lookup (mapping_of p) k  0}"
    by auto
  have " k. MPoly_Type.coeff p (Poly_Mapping.single v k) = 0" unfolding coeff_def eventually_cofinite
    using  finite_imageD[OF finite_subset[OF 0 Poly_Mapping.finite_lookup]] inj_single by (metis inj_eq inj_onI)
  then show ?thesis
    unfolding mpoly_to_poly_def by (simp add: Abs_poly_inverse)
qed

lemma mpoly_to_poly_inverse:
assumes "vars p  {v}"
shows "poly_to_mpoly v (mpoly_to_poly v p) = p"
proof -
  define f where "f = (λm. Polynomial.coeff (mpoly_to_poly v p) (Poly_Mapping.lookup m v) when Poly_Mapping.keys m  {v})"
  have "finite {m. f m  0}" unfolding f_def using poly_to_mpoly_finite by blast
  have "Abs_poly_mapping f = mapping_of p"
  proof (rule "Poly_Mapping.poly_mapping_eqI")
    fix m
    show "Poly_Mapping.lookup (Abs_poly_mapping f) m = Poly_Mapping.lookup (mapping_of p) m"
    proof (cases "Poly_Mapping.keys m  {v}")
      assume "Poly_Mapping.keys m  {v}"
      then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF ‹finite {m. f m  0}] unfolding f_def
        unfolding coeff_mpoly_to_poly coeff_def using when_simps(1) apply simp
        using keys_single lookup_not_eq_zero_eq_in_keys lookup_single_eq
        lookup_single_not_eq poly_mapping_eqI subset_singletonD
        by (metis (no_types, lifting) aux lookup_eq_zero_in_keys_contradict)
    next
      assume "¬Poly_Mapping.keys m  {v}"
      then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF ‹finite {m. f m  0}] unfolding f_def
        using ‹vars p  {v} unfolding vars_def by (metis (no_types, lifting) UN_I lookup_not_eq_zero_eq_in_keys subsetCE subsetI when_def)
    qed
  qed
  then show ?thesis
    unfolding poly_to_mpoly_def f_def  by (simp add: mapping_of_inverse)
qed

lemma poly_to_mpoly_inverse: "mpoly_to_poly v (poly_to_mpoly v p) = p"
  unfolding mpoly_to_poly_def coeff_poly_to_mpoly by (simp add: coeff_inverse)

lemma poly_to_mpoly0: "poly_to_mpoly v 0 = 0"
proof -
  have "m. (Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m  {v}) = 0" by simp
  have "Abs_poly_mapping (λm. Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m  {v}) = 0"
    apply (rule Poly_Mapping.poly_mapping_eqI) unfolding lookup_Abs_poly_mapping[OF poly_to_mpoly_finite] by auto
  then show ?thesis using poly_to_mpoly_def zero_mpoly.abs_eq by (metis (no_types))
qed

lemma mpoly_to_poly_add: "mpoly_to_poly v (p1 + p2) = mpoly_to_poly v p1 + mpoly_to_poly v p2"
  unfolding  Polynomial.plus_poly.abs_eq More_MPoly_Type.coeff_add coeff_mpoly_to_poly
  using mpoly_to_poly_def by auto

lemma poly_eq_insertion:
assumes "vars p  {v}"
shows "poly (mpoly_to_poly v p) x = insertion (λv. x) p"
using assms proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (cases "a=0")
    case True
    then show ?thesis
      by (metis MPoly_Type.monom.abs_eq insertion_zero monom_zero poly_0 poly_to_mpoly0 poly_to_mpoly_inverse single_zero)
  next
    case False
    then have "Poly_Mapping.keys m  {v}" using monom unfolding vars_def MPoly_Type.mapping_of_monom keys_single by simp
    then have "v'. v'v  Poly_Mapping.lookup m v' = 0" unfolding vars_def by (auto simp: in_keys_iff)
    then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
      by (metis lookup_single_eq lookup_single_not_eq poly_mapping_eqI)
    then have 0:"insertion (λv. x) (MPoly_Type.monom m a) = a * x ^ (Poly_Mapping.lookup m v)"
      using insertion_single by metis
    have "k. Poly_Mapping.single v k = m  Poly_Mapping.lookup m v = k"
      using m = Poly_Mapping.single v (Poly_Mapping.lookup m v) by auto
    then have "monom a (Poly_Mapping.lookup m v) = (Abs_poly (λk. if Poly_Mapping.single v k = m then a else 0))"
      by (simp add: Polynomial.monom.abs_eq)
    then show ?thesis unfolding mpoly_to_poly_def More_MPoly_Type.coeff_monom 0 when_def by (metis poly_monom)
  qed
next
  case (sum p1 p2 m a)
  then have "poly (mpoly_to_poly v p1) x = insertion (λv. x) p1"
            "poly (mpoly_to_poly v p2) x = insertion (λv. x) p2"
    by (simp_all add: vars_add_monom)
  then show ?case unfolding insertion_add mpoly_to_poly_add by simp
qed

text ‹Using the new connection between MPoly and univariate polynomials, we can transfer:›

lemma univariate_mpoly_roots_finite:
fixes p::"'a::idom mpoly"
assumes "vars p  {v}" "p  0"
shows "finite {x. insertion (λv. x) p = 0}"
using poly_roots_finite[of "mpoly_to_poly v p", unfolded poly_eq_insertion[OF ‹vars p  {v}]]
using assms(1) assms(2) mpoly_to_poly_inverse poly_to_mpoly0 by fastforce

end

Theory Polynomials

(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section ‹Polynomials›

(* TODO: attempt to turn polynomials into type *)

theory Polynomials
imports 
  "Abstract-Rewriting.SN_Orders"
  Matrix.Utility 
begin

subsection ‹
Polynomials represented as trees
›
datatype (vars_tpoly: 'v, nums_tpoly: 'a)tpoly = PVar 'v | PNum 'a | PSum "('v,'a)tpoly list" | PMult "('v,'a)tpoly list"

type_synonym ('v,'a)assign = "'v  'a"

primrec eval_tpoly :: "('v,'a::{monoid_add,monoid_mult})assign  ('v,'a)tpoly  'a"
where "eval_tpoly α (PVar x) = α x"
   |  "eval_tpoly α (PNum a) = a"
   |  "eval_tpoly α (PSum ps) = sum_list (map (eval_tpoly α) ps)"
   |  "eval_tpoly α (PMult ps) = prod_list (map (eval_tpoly α) ps)"

subsection ‹Polynomials represented in normal form as lists of monomials›
text ‹
  The internal representation of polynomials is a sum of products of monomials with coefficients
  where all coefficients are non-zero, and all monomials are different
›
 
text ‹Definition of type monom›


type_synonym 'v monom_list = "('v × nat)list" 
text ‹
\begin{itemize}
\item $[(x,n),(y,m)]$ represent $x^n \cdot y^m$
\item invariants: all powers are $\geq 1$ and each variable occurs at most once \\
   hence: $[(x,1),(y,2),(x,2)]$ will not occur, but $[(x,3),(y,2)]$;
          $[(x,1),(y,0)]$ will not occur, but $[(x,1)]$
\end{itemize}
›

context linorder
begin
definition monom_inv :: "'a monom_list  bool" where 
  "monom_inv m  ( (x,n)  set m. 1  n)  distinct (map fst m)  sorted (map fst m)"

fun eval_monom_list :: "('a,'b :: comm_semiring_1)assign  ('a monom_list)  'b" where 
  "eval_monom_list α [] = 1"
| "eval_monom_list α ((x,p) # m) = eval_monom_list α m * (α x)^p"

lemma eval_monom_list[simp]: "eval_monom_list α (m @ n) = eval_monom_list α m * eval_monom_list α n"
  by (induct m, auto simp: field_simps)

definition sum_var_list :: "'a monom_list  'a  nat" where
  "sum_var_list m x  sum_list (map (λ (y,c). if x = y then c else 0) m)"

lemma sum_var_list_not: "x  fst ` set m  sum_var_list m x = 0"
  unfolding sum_var_list_def by (induct m, auto)

text ‹
show that equality of monomials is equivalent to statement that 
all variables occur with the same (accumulated) power;
afterwards properties like transitivity, etc. are easy to prove›

lemma monom_inv_Cons: assumes "monom_inv ((x,p) # m)" 
  and "y  x" shows "y  fst ` set m" 
proof -
  define M where "M = map fst m" 
  from assms[unfolded monom_inv_def] 
  have "distinct (x # map fst m)" "sorted (x # map fst m)"  by auto
  with assms(2) have "y  set (map fst m)" unfolding M_def[symmetric]
    by (induct M, auto)
  thus ?thesis by auto
qed

lemma eq_monom_sum_var_list: assumes "monom_inv m" and "monom_inv n"
  shows "(m = n) = ( x. sum_var_list m x = sum_var_list n x)" (is "?l = ?r")
using assms
proof (induct m arbitrary: n)
  case Nil
  show ?case 
  proof (cases n)
    case (Cons yp nn)
    obtain y p where yp: "yp = (y,p)" by (cases yp, auto)
    with Cons Nil(2)[unfolded monom_inv_def] have p: "0 < p" by auto
    show ?thesis by (simp add: Cons, rule exI[of _ y], simp add: sum_var_list_def yp p)
  qed simp
next
  case (Cons xp m)
  obtain x p where xp: "xp = (x,p)" by (cases xp, auto)
  with Cons(2) have p: "0 < p" and x: "x  fst ` set m" and m: "monom_inv m" unfolding monom_inv_def 
    by (auto)
  show ?case 
  proof (cases n)
    case Nil
    thus ?thesis by (auto simp: xp sum_var_list_def p intro!: exI[of _ x])
  next
    case n: (Cons yq n')
    from Cons(3)[unfolded n] have n': "monom_inv n'" by (auto simp: monom_inv_def)
    show ?thesis
    proof (cases "yq = xp")
      case True
      show ?thesis unfolding n True using Cons(1)[OF m n'] by (auto simp: xp sum_var_list_def)
    next
      case False
      obtain y q where yq: "yq = (y,q)" by force
      from Cons(3)[unfolded n yq monom_inv_def] have q: "q > 0" by auto
      define z where "z = min x y" 
      have zm: "z  fst ` set m" using Cons(2) unfolding xp z_def
        by (rule monom_inv_Cons, simp)
      have zn': "z  fst ` set n'" using Cons(3) unfolding n yq z_def
        by (rule monom_inv_Cons, simp)
      have smz: "sum_var_list (xp # m) z = sum_var_list [(x,p)] z" 
        using sum_var_list_not[OF zm] by (simp add: sum_var_list_def xp)
      also have "  sum_var_list [(y,q)] z" using False unfolding xp yq 
        by (auto simp: sum_var_list_def z_def p q min_def)
      also have "sum_var_list [(y,q)] z = sum_var_list n z" 
        using sum_var_list_not[OF zn'] by (simp add: sum_var_list_def n yq)
      finally show ?thesis using False unfolding n by auto
    qed
  qed
qed

text ‹
  equality of monomials is also a complete for several carriers, e.g. the naturals, integers, where $x^p = x^q$ implies $p = q$.
  note that it is not complete for carriers like the Booleans where e.g. $x^{Suc(m)} = x^{Suc(n)}$ for all $n,m$.
›
(*
lemma eq_monom_inv: 
  fixes m :: "'v :: linorder monom_list"
  assumes exp_inject: "⋀ p q :: nat. ∃ base :: 'a :: poly_carrier. base^p = base^q ⟹ p = q" 
  and m: "monom_inv m" and n: "monom_inv n" 
  shows "(m = n) = (∀ α :: ('v,'a :: poly_carrier)assign. eval_monom_list α m = eval_monom_list α n)"
proof(intro iffI allI, rule eq_monom_list)
  assume "∀ α :: ('v,'a :: poly_carrier)assign. eval_monom_list α m = eval_monom_list α n"
  with m n show "m = n"
  proof (induct m arbitrary: n)
    case Nil
    show ?case 
    proof (cases n)
      case (Cons yq nn)
      with Nil obtain y q where yq: "yq = (y,q)" and "1 ≤ q" by (cases yq, auto simp: monom_inv_def)
      then obtain qq where q: "q = Suc (qq)" by (cases q, auto)
      from Nil(3) have "1 = eval_monom_list (λ x. 0 :: 'a) n" (is "?one = _") by simp
      also have "… = 0" by (simp add: Cons yq q)
      finally show ?thesis by simp
    qed simp
  next
    case (Cons xp m) note mCons = this
    show ?case
    proof (cases xp)
      case (Pair x p)
      let ?ass = "(λ v y. if x = y then v else 1 :: 'a)"
      {
        fix v :: 'a and m :: "'v monom_list"
        assume "x ∉ fst ` (set m)"
        hence "eval_monom_list (?ass v) m = 1"
        proof (induct m)
          case (Cons yp m)
          thus ?case 
            by (cases yp, cases "fst yp = x", auto)
        qed simp
      } note ass = this
      from Cons(2)[unfolded Pair] obtain pp where p: "p = Suc pp" and xm: "x ∉ fst ` (set m)" unfolding monom_inv_def by (cases p, auto)
      from ass[OF xm] have "⋀ v. eval_monom_list (?ass v) (xp # m) = v * v^pp" by (simp add: Pair p)
      with Cons(4) have eval: "⋀ v. eval_monom_list (?ass v) n = v * v^pp" by auto
      show ?thesis 
      proof (cases "List.extract (λ yq. fst yq = x) n")
        case None
        with ass[of n] have "⋀ v. eval_monom_list (?ass v) n = 1" by (auto simp: extract_None_iff)
        from this[of 0] eval[of 0] show ?thesis by simp
      next
        case (Some res)
        obtain n1 yq n2 where "res = (n1,yq,n2)" by (cases res, auto)
        then obtain y q where "res = (n1,(y,q),n2)" by (cases yq, auto)        
        from extract_SomeE[OF Some[simplified this]] mCons(2)  Some Pair this have n: "n = n1 @ (x,q) # n2" and res: "res = (n1,(x,q),n2)" by auto
        from mCons(3)[unfolded n] have xn: "x ∉ fst ` (set (n1 @ n2))" unfolding monom_inv_def by auto
        have "⋀ v. eval_monom_list (?ass v) n = v^q * eval_monom_list  (?ass v) (n1 @ n2)" unfolding n by (auto simp: field_simps)
        from eval[unfolded this ass[OF xn]] have id: "⋀ v :: 'a. v^p = v^q" using p by auto
        from exp_inject[of p q] id have pq: "p = q" by auto
        have rec: "((xp # m) =m n) = (m =m (n1 @ n2))" by (simp add: Pair Some res pq)
        have ass: "∀α :: ('v,'a)assign. eval_monom_list  α m = eval_monom_list α (n1 @ n2)"
        proof
          fix α :: "('v,'a)assign"
          show "eval_monom_list α m = eval_monom_list α (n1 @ n2)"
          proof (rule ccontr)
            assume neq: "¬ ?thesis"
            let ?ass =  "λ y :: 'v. if x = y then 1 :: 'a else α y"
            {
              fix m :: "'v monom_list"
              assume "x ∉ fst ` set m"
              hence "eval_monom_list α m = eval_monom_list ?ass m"
                by (induct m, auto)
            } note ass = this
            have "eval_monom_list α (n1 @ n2) = eval_monom_list ?ass (n1 @ n2)" using ass[OF xn] .
            also have "… = eval_monom_list ?ass n" unfolding n by auto
            also have "… = eval_monom_list ?ass ((xp # m))" using mCons(4) by auto
            also have "… = eval_monom_list ?ass m" unfolding Pair by simp
            also have "… = eval_monom_list α m" using ass[OF xm] by simp 
            also have "… ≠ eval_monom_list α (n1 @ n2)" by (rule neq)
            finally show False by simp
          qed
        qed
        from mCons(2) mCons(3) have "monom_inv m" and "monom_inv (n1 @ n2)" unfolding monom_inv_def n by auto
        from mCons(1)[OF this ass] rec show ?thesis by simp
      qed
    qed    
  qed
qed simp  *)

abbreviation (input) monom_list_vars :: "'a monom_list  'a set"
  where "monom_list_vars m  fst ` set m"

fun monom_mult_list :: "'a monom_list  'a monom_list  'a monom_list" where 
  "monom_mult_list [] n = n"
| "monom_mult_list ((x,p) # m) n = (case n of
     Nil  (x,p) # m 
   | (y,q) # n'  if x = y then (x,p + q) # monom_mult_list m n' else
       if x < y then (x,p) # monom_mult_list m n else (y,q) # monom_mult_list ((x,p) # m) n')"

lemma monom_list_mult_list_vars: "monom_list_vars (monom_mult_list m1 m2) = monom_list_vars m1  monom_list_vars m2"
  by (induct m1 m2 rule: monom_mult_list.induct, auto split: list.splits)


lemma monom_mult_list_inv: "monom_inv m1  monom_inv m2  monom_inv (monom_mult_list m1 m2)"
proof (induct m1 m2 rule: monom_mult_list.induct)
  case (2 x p m n')
  note IH = 2(1-3)
  note xpm = 2(4)
  note n' = 2(5)
  show ?case
  proof (cases n')
    case Nil
    with xpm show ?thesis by auto
  next
    case (Cons yq n)
    then obtain y q where id: "n' = ((y,q) # n)" by (cases yq, auto)
    from xpm have m: "monom_inv m" and p: "p > 0" and x: "x  fst ` set m" 
      and xm: " z. z  fst ` set m  x  z" 
      unfolding monom_inv_def by (auto)
    from n'[unfolded id] have n: "monom_inv n" and q: "q > 0" and y: "y  fst ` set n" 
      and yn: " z. z  fst ` set n  y  z" 
      unfolding monom_inv_def by (auto)
    show ?thesis
    proof (cases "x = y")
      case True
      hence res: "monom_mult_list ((x, p) # m) n' = (x, p + q) # monom_mult_list m n" 
        by (simp add: id)
      from IH(1)[OF id refl True m n] have inv: "monom_inv (monom_mult_list m n)" by simp
      show ?thesis unfolding res using inv p x y True xm yn
        by (fastforce simp add: monom_inv_def monom_list_mult_list_vars)
    next
      case False
      show ?thesis
      proof (cases "x < y")
        case True
        hence res: "monom_mult_list ((x, p) # m) n' = (x,p) # monom_mult_list m n'" 
          by (auto simp add: id)
        from IH(2)[OF id refl False True m n'] have inv: "monom_inv (monom_mult_list m n')" .
        show ?thesis unfolding res using inv p x y True xm yn unfolding id
          by (fastforce simp add: monom_inv_def monom_list_mult_list_vars)
      next
        case gt: False
        with False have lt: "y < x" by auto        
        hence res: "monom_mult_list ((x, p) # m) n' = (y,q) # monom_mult_list ((x, p) # m) n" 
          using False by (auto simp add: id)
        from lt have zm: "z  x  (z,b)  set m" for z b using xm[of z] x by force
        from zm[of y] lt have ym: "(y,b)  set m" for b by auto
        from yn have yn': "(a, b)  set n  y  a" for a b by force
        from IH(3)[OF id refl False gt xpm n] have inv: "monom_inv (monom_mult_list ((x, p) # m) n)" .
        define xpm where "xpm = ((x,p) # m)" 
        have xpm': "fst ` set xpm = insert x (fst ` set m)" unfolding xpm_def by auto
        show ?thesis unfolding res using inv p q x y False gt ym lt xm yn' zm xpm' unfolding id xpm_def[symmetric]
          by (auto simp add: monom_inv_def monom_list_mult_list_vars)
      qed
    qed
  qed
qed auto

lemma monom_inv_ConsD: "monom_inv (x # xs)  monom_inv xs" 
  by (auto simp: monom_inv_def)

lemma sum_var_list_monom_mult_list:  "sum_var_list (monom_mult_list m n) x = sum_var_list m x + sum_var_list n x"
proof (induct m n rule: monom_mult_list.induct)
  case (2 x p m n)
  thus ?case by (cases n; cases "hd n", auto split: if_splits simp: sum_var_list_def)
qed (auto simp: sum_var_list_def)

lemma monom_mult_list_inj: assumes m: "monom_inv m" and m1: "monom_inv m1" and m2: "monom_inv m2"
  and eq: "monom_mult_list m m1 = monom_mult_list m m2"
  shows "m1 = m2"
proof -
  from eq sum_var_list_monom_mult_list[of m] show ?thesis
    by (auto simp: eq_monom_sum_var_list[OF m1 m2] eq_monom_sum_var_list[OF monom_mult_list_inv[OF m m1] monom_mult_list_inv[OF m m2]])
qed

lemma monom_mult_list[simp]: "eval_monom_list α (monom_mult_list m n) = eval_monom_list α m * eval_monom_list α n"
  by (induct m n rule: monom_mult_list.induct, auto split: list.splits prod.splits simp: field_simps power_add)
end

declare monom_mult_list.simps[simp del]

typedef (overloaded) 'v monom = "Collect (monom_inv :: 'v :: linorder monom_list  bool)"
  by (rule exI[of _ Nil], auto simp: monom_inv_def)

setup_lifting type_definition_monom

lift_definition eval_monom :: "('v :: linorder,'a :: comm_semiring_1)assign  'v monom  'a"
  is eval_monom_list .

lift_definition sum_var :: "'v :: linorder monom  'v  nat" is sum_var_list .

instantiation monom :: (linorder) comm_monoid_mult
begin

lift_definition times_monom :: "'a monom  'a monom  'a monom" is monom_mult_list
  using monom_mult_list_inv by auto

lift_definition one_monom :: "'a monom" is Nil
  by (auto simp: monom_inv_def)

instance
proof
  fix a b c :: "'a monom" 
  show "a * b * c = a * (b * c)" 
    by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list)
  show "a * b = b * a"
    by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list)
  show "1 * a = a" 
    by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list monom_mult_list.simps)
qed
end

lemma eq_monom_sum_var: "m = n  ( x. sum_var m x = sum_var n x)"
  by (transfer, auto simp: eq_monom_sum_var_list)

lemma eval_monom_mult[simp]: "eval_monom α (m * n) = eval_monom α m * eval_monom α n"
  by (transfer, rule monom_mult_list)

lemma sum_var_monom_mult:  "sum_var (m * n) x = sum_var m x + sum_var n x"
  by (transfer, rule sum_var_list_monom_mult_list)

lemma monom_mult_inj: fixes m1 :: "_ monom"
  shows "m * m1 = m * m2  m1 = m2"
  by (transfer, rule monom_mult_list_inj, auto) 


lemma one_monom_inv_sum_var_inv[simp]: "sum_var 1 x = 0" 
  by (transfer, auto simp: sum_var_list_def)

lemma eval_monom_1[simp]: "eval_monom  α 1 = 1" 
  by (transfer, auto)

lift_definition var_monom :: "'v :: linorder  'v monom" is "λ x. [(x,1)]" 
  by (auto simp: monom_inv_def)

lemma var_monom_1[simp]: "var_monom x  1" 
  by (transfer, auto)

lemma eval_var_monom[simp]: "eval_monom α (var_monom x) = α x" 
  by (transfer, auto)

lemma sum_var_monom_var: "sum_var (var_monom x) y = (if x = y then 1 else 0)"
  by (transfer, auto simp: sum_var_list_def)

instantiation monom :: ("{equal,linorder}")equal
begin

lift_definition equal_monom :: "'a monom  'a monom  bool" is "(=)" .

instance by (standard, transfer, auto)
end

text ‹
Polynomials are represented with as sum of monomials multiplied by some coefficient 
›
type_synonym ('v,'a)poly = "('v monom × 'a)list"

text ‹
The polynomials we construct satisfy the following invariants:
\begin{itemize}
\item all coefficients are non-zero
\item the monomial list is distinct 
\end{itemize}
›

definition poly_inv :: "('v,'a :: zero)poly  bool"
  where "poly_inv p  ( c  snd ` set p. c  0)  distinct (map fst p)"

abbreviation eval_monomc where "eval_monomc α mc  eval_monom α (fst mc) * (snd mc)"

primrec eval_poly :: "('v :: linorder, 'a :: comm_semiring_1)assign  ('v,'a)poly  'a" where 
  "eval_poly α [] = 0"
| "eval_poly α (mc # p) = eval_monomc α mc + eval_poly α p"


definition poly_const :: "'a :: zero  ('v :: linorder,'a)poly" where
  "poly_const a = (if a = 0 then [] else [(1,a)])" 

lemma poly_const[simp]: "eval_poly α (poly_const a) = a" 
  unfolding poly_const_def by auto

lemma poly_const_inv: "poly_inv (poly_const a)" 
  unfolding poly_const_def poly_inv_def by auto

fun poly_add :: "('v,'a)poly  ('v,'a :: semiring_0)poly  ('v,'a)poly" where
  "poly_add [] q = q"
| "poly_add ((m,c) # p) q = (case List.extract (λ mc. fst mc = m) q of
    None  (m,c) # poly_add p q
  | Some (q1,(_,d),q2)  if (c+d = 0) then poly_add p (q1 @ q2) else (m,c+d) # poly_add p (q1 @ q2))"
 
lemma eval_poly_append[simp]: "eval_poly α (mc1 @ mc2) = eval_poly α mc1 + eval_poly α mc2"
  by (induct mc1, auto simp: field_simps)

abbreviation poly_monoms :: "('v,'a)poly  'v monom set"
  where "poly_monoms p  fst ` set p"

lemma poly_add_monoms: "poly_monoms (poly_add p1 p2)  poly_monoms p1  poly_monoms p2"
proof (induct p1 arbitrary: p2)
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  hence m: "m  poly_monoms (mc # p1)" by auto
  show ?case
  proof (cases "List.extract (λ nd. fst nd = m) p2")
    case None
    with Cons m show ?thesis by (auto simp: mc)
  next
    case (Some res)
    obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
    from extract_SomeE[OF Some[simplified res]] res obtain d where q: "p2 = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
    show ?thesis
      by (simp add: mc Some res, rule subset_trans[OF Cons[of "q1 @ q2"]], auto simp: q)
  qed
qed simp
  

lemma poly_add_inv: "poly_inv p  poly_inv q  poly_inv (poly_add p q)"
proof (induct p arbitrary: q)
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  with Cons(2) have p: "poly_inv p" and c: "c  0" and mp: " mm  fst ` set p. (¬ mm = m)" unfolding poly_inv_def by auto
  show ?case
  proof (cases "List.extract (λ mc. fst mc = m) q")
    case None
    hence mq: " mm  fst ` set q. ¬ mm = m" by (auto simp: extract_None_iff)
    { 
      fix mm 
      assume "mm  fst ` set (poly_add p q)" 
      then obtain dd where "(mm,dd)  set (poly_add p q)" by auto
      with poly_add_monoms have "mm  poly_monoms p  mm  poly_monoms q" by force
      hence "¬ mm = m" using mp mq by auto
    } note main = this
    show ?thesis using Cons(1)[OF p Cons(3)] unfolding poly_inv_def using main by (auto simp add: None mc c)
  next
    case (Some res)
    obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
    from extract_SomeE[OF Some[simplified res]] res obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
    from q Cons(3) have q1q2: "poly_inv (q1 @ q2)" unfolding poly_inv_def by auto
    from Cons(1)[OF p q1q2]  have main1: "poly_inv (poly_add p (q1 @ q2))" .
    {
      fix mm
      assume "mm  fst ` set (poly_add p (q1 @ q2))"
      then obtain dd where "(mm,dd)  set (poly_add p (q1 @ q2))" by auto
      with poly_add_monoms have "mm  poly_monoms p  mm  poly_monoms (q1 @ q2)" by force
      hence "mm  m"
      proof
        assume "mm  poly_monoms p"
        thus ?thesis using mp  by auto
      next
        assume member: "mm  poly_monoms (q1 @ q2)"
        from member have "mm  poly_monoms q1  mm  poly_monoms q2" by auto
        thus "mm  m"
        proof
          assume "mm  poly_monoms q2"
          with Cons(3)[simplified q]
          show ?thesis unfolding poly_inv_def by auto
        next
          assume "mm  poly_monoms q1"
          with Cons(3)[simplified q]
          show ?thesis unfolding poly_inv_def by auto
        qed
      qed
    } note main2 = this
    show ?thesis using  main1[unfolded poly_inv_def] main2
      by (auto simp: poly_inv_def mc Some res)
  qed
qed simp

lemma poly_add[simp]: "eval_poly α (poly_add p q) = eval_poly α p + eval_poly α q"
proof (induct p arbitrary: q)
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  show ?case
  proof (cases "List.extract (λ mc. fst mc = m) q")
    case None
    show ?thesis by (simp add: Cons[of q] mc None field_simps)
  next
    case (Some res)
    obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
    from extract_SomeE[OF Some[simplified res]] res obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
    {
      fix x
      assume c: "c + d = 0"
      have "c * x + d * x = (c + d) * x" by (auto simp: field_simps)
      also have " = 0 * x" by (simp only: c)
      finally have "c * x + d * x = 0" by simp
    } note id = this
    show ?thesis 
      by (simp add: Cons[of "q1 @ q2"] mc Some res, simp only: q, simp add: field_simps, auto simp: field_simps id)
  qed
qed simp

declare poly_add.simps[simp del]

fun monom_mult_poly :: "('v :: linorder monom × 'a)  ('v,'a :: semiring_0)poly  ('v,'a)poly" where 
  "monom_mult_poly _ [] = []"
| "monom_mult_poly (m,c) ((m',d) # p) = (if c * d = 0 then monom_mult_poly (m,c) p else (m * m', c * d) # monom_mult_poly (m,c) p)"

lemma monom_mult_poly_inv: "poly_inv p  poly_inv (monom_mult_poly (m,c) p)"
proof (induct p)
  case Nil thus ?case by (simp add: poly_inv_def)
next
  case (Cons md p)
  obtain m' d where md: "md = (m',d)" by (cases md, auto)
  with Cons(2) have p: "poly_inv p" unfolding poly_inv_def by auto
  from Cons(1)[OF p] have prod: "poly_inv (monom_mult_poly (m,c) p)" .
  {
    fix mm 
    assume "mm  fst ` set (monom_mult_poly (m,c) p)" 
       and two: "mm = m * m'"
    then obtain dd where one: "(mm,dd)  set (monom_mult_poly (m,c) p)" by auto
    have "poly_monoms (monom_mult_poly (m,c) p)  (*) m ` poly_monoms p" 
    proof (induct p, simp)
      case (Cons md p)
      thus ?case
        by (cases md, auto)
    qed
    with one have "mm  (*) m ` poly_monoms p" by force
    then obtain mmm where mmm: "mmm  poly_monoms p" and mm: "mm = m * mmm" by blast
    from Cons(2)[simplified md] mmm have not1: "¬ mmm = m'" unfolding poly_inv_def by auto
    from mm two have "m * mmm = m * m'" by simp
    from monom_mult_inj[OF this] not1 
    have False by simp
  } 
  thus ?case 
    by (simp add: md prod, intro impI, auto simp: poly_inv_def prod[simplified poly_inv_def])
qed

lemma monom_mult_poly[simp]: "eval_poly α (monom_mult_poly mc p) = eval_monomc α mc * eval_poly α p"
proof (cases mc)
  case (Pair m c)
  show ?thesis
  proof (simp add: Pair, induct p)
    case (Cons nd q)
    obtain n d where nd: "nd = (n,d)" by (cases nd, auto)
    show ?case
    proof (cases "c * d = 0")
      case False
      thus ?thesis by (simp add: nd Cons field_simps)
    next
      case True
      let ?l = "c * (d * (eval_monom α m * eval_monom α n))"
      have "?l = (c * d) * (eval_monom α m * eval_monom α n)" 
        by (simp only: field_simps)
      also have " = 0" by (simp only: True, simp add: field_simps)
      finally have l: "?l = 0" .
      show ?thesis 
        by (simp add: nd Cons True, simp add: field_simps l) 
    qed
  qed simp
qed

declare monom_mult_poly.simps[simp del]

definition poly_minus :: "('v :: linorder,'a :: ring_1)poly  ('v,'a)poly  ('v,'a)poly" where
  "poly_minus f g = poly_add f (monom_mult_poly (1,-1) g)" 
  
lemma poly_minus[simp]: "eval_poly α (poly_minus f g) = eval_poly α f - eval_poly α g" 
  unfolding poly_minus_def by simp

lemma poly_minus_inv: "poly_inv f  poly_inv g  poly_inv (poly_minus f g)" 
  unfolding poly_minus_def by (intro poly_add_inv monom_mult_poly_inv)

fun poly_mult :: "('v :: linorder, 'a :: semiring_0)poly  ('v,'a)poly  ('v,'a)poly" where 
  "poly_mult [] q = []"
| "poly_mult (mc # p) q = poly_add (monom_mult_poly mc q) (poly_mult p q)"

lemma poly_mult_inv: assumes p: "poly_inv p" and q: "poly_inv q"
  shows "poly_inv (poly_mult p q)"
using p
proof (induct p)
  case Nil thus ?case by (simp add: poly_inv_def)
next
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  with Cons(2) have p: "poly_inv p" unfolding poly_inv_def by auto
  show ?case
    by (simp add: mc, rule poly_add_inv[OF monom_mult_poly_inv[OF q] Cons(1)[OF p]])
qed

lemma poly_mult[simp]: "eval_poly α (poly_mult p q) = eval_poly α p * eval_poly α q"
  by (induct p, auto simp: field_simps)

declare poly_mult.simps[simp del]

definition zero_poly :: "('v,'a)poly"
where "zero_poly  []"

lemma zero_poly_inv: "poly_inv zero_poly" unfolding zero_poly_def poly_inv_def by auto

definition one_poly :: "('v :: linorder,'a :: semiring_1)poly" where 
  "one_poly  [(1,1)]"

lemma one_poly_inv: "poly_inv one_poly" unfolding one_poly_def poly_inv_def monom_inv_def by auto

lemma poly_one[simp]: "eval_poly α one_poly = 1" 
  unfolding one_poly_def by simp

lemma poly_zero_add: "poly_add zero_poly p = p" unfolding zero_poly_def using poly_add.simps by auto

lemma poly_zero_mult: "poly_mult zero_poly p = zero_poly" unfolding zero_poly_def using poly_mult.simps by auto

text ‹equality of polynomials›
definition eq_poly :: "('v :: linorder, 'a :: comm_semiring_1)poly  ('v,'a)poly  bool" (infix "=p" 51)
where "p =p q   α. eval_poly α p = eval_poly α q"

lemma poly_one_mult: "poly_mult one_poly p =p p" 
  unfolding eq_poly_def one_poly_def by simp

lemma eq_poly_refl[simp]: "p =p p" unfolding eq_poly_def by auto

lemma eq_poly_trans[trans]: "p1 =p p2; p2 =p p3  p1 =p p3"
unfolding eq_poly_def by auto

lemma poly_add_comm: "poly_add p q =p poly_add q p" unfolding eq_poly_def by (auto simp: field_simps)

lemma poly_add_assoc: "poly_add p1 (poly_add p2 p3) =p poly_add (poly_add p1 p2) p3" unfolding eq_poly_def by (auto simp: field_simps)

lemma poly_mult_comm: "poly_mult p q =p poly_mult q p" unfolding eq_poly_def by (auto simp: field_simps)

lemma poly_mult_assoc: "poly_mult p1 (poly_mult p2 p3) =p poly_mult (poly_mult p1 p2) p3" unfolding eq_poly_def by (auto simp: field_simps)

lemma poly_distrib: "poly_mult p (poly_add q1 q2) =p poly_add (poly_mult p q1) (poly_mult p q2)" unfolding eq_poly_def by (auto simp: field_simps)


subsection ‹Computing normal forms of polynomials›
fun
  poly_of :: "('v :: linorder,'a :: comm_semiring_1)tpoly  ('v,'a)poly"
where "poly_of (PNum i) = (if i = 0 then [] else [(1,i)])"
    | "poly_of (PVar x) = [(var_monom x,1)]"
    | "poly_of (PSum []) = zero_poly" 
    | "poly_of (PSum (p # ps)) = (poly_add (poly_of p) (poly_of (PSum ps)))"
    | "poly_of (PMult []) = one_poly" 
    | "poly_of (PMult (p # ps)) = (poly_mult (poly_of p) (poly_of (PMult ps)))"

text ‹
  evaluation is preserved by poly\_of
›
lemma poly_of: "eval_poly α (poly_of p) = eval_tpoly α p"
by (induct p rule: poly_of.induct, (simp add: zero_poly_def one_poly_def)+)

text ‹
  poly\_of only generates polynomials that satisfy the invariant
›
lemma poly_of_inv: "poly_inv (poly_of p)"
by (induct p rule: poly_of.induct, 
    simp add: poly_inv_def monom_inv_def,
    simp add: poly_inv_def monom_inv_def,
    simp add: zero_poly_inv,
    simp add: poly_add_inv,
    simp add: one_poly_inv,
    simp add: poly_mult_inv)


subsection ‹Powers and substitutions of polynomials›
fun poly_power :: "('v :: linorder, 'a :: comm_semiring_1)poly  nat  ('v,'a)poly" where 
  "poly_power _ 0 = one_poly"
| "poly_power p (Suc n) = poly_mult p (poly_power p n)"

lemma poly_power[simp]: "eval_poly α (poly_power p n) = (eval_poly α p) ^ n"
  by (induct n, auto simp: one_poly_def)

lemma poly_power_inv: assumes p: "poly_inv p" 
  shows "poly_inv (poly_power p n)"
  by (induct n, simp add: one_poly_inv, simp add: poly_mult_inv[OF p])

declare poly_power.simps[simp del]

fun monom_list_subst :: "('v  ('w :: linorder,'a :: comm_semiring_1)poly)  'v monom_list  ('w,'a)poly" where 
  "monom_list_subst σ [] = one_poly"
| "monom_list_subst σ ((x,p) # m) = poly_mult (poly_power (σ x) p) (monom_list_subst σ m)"

lift_definition monom_list :: "'v :: linorder monom  'v monom_list" is "λ x. x" .

definition monom_subst :: "('v :: linorder  ('w :: linorder,'a :: comm_semiring_1)poly)  'v monom  ('w,'a)poly" where 
  "monom_subst σ m = monom_list_subst σ (monom_list m)"  

lemma monom_list_subst_inv: assumes sub: " x. poly_inv (σ x)" 
  shows "poly_inv (monom_list_subst σ m)"
proof (induct m)
  case Nil thus ?case by (simp add: one_poly_inv)
next
  case (Cons xp m)
  obtain x p where xp: "xp = (x,p)" by (cases xp, auto)
  show ?case by (simp add: xp, rule poly_mult_inv[OF poly_power_inv[OF sub] Cons])
qed

lemma monom_subst_inv: assumes sub: " x. poly_inv (σ x)" 
  shows "poly_inv (monom_subst σ m)"
  unfolding monom_subst_def by (rule monom_list_subst_inv[OF sub])

lemma monom_subst[simp]: "eval_poly α (monom_subst σ m) = eval_monom (λ v. eval_poly α (σ v)) m"
  unfolding monom_subst_def
proof (transfer fixing: α σ, clarsimp)
  fix m 
  show "monom_inv m  eval_poly α (monom_list_subst σ m) = eval_monom_list (λv. eval_poly α (σ v)) m"
    by (induct m, simp add: one_poly_def, auto simp: field_simps monom_inv_ConsD)
qed

fun poly_subst :: "('v :: linorder  ('w :: linorder,'a :: comm_semiring_1)poly)  ('v,'a)poly  ('w,'a)poly" where 
  "poly_subst σ [] = zero_poly"
| "poly_subst σ ((m,c) # p) = poly_add (poly_mult [(1,c)] (monom_subst σ m)) (poly_subst σ p)"

lemma poly_subst_inv: assumes sub: " x. poly_inv (σ x)" and p: "poly_inv p"
  shows "poly_inv (poly_subst σ p)"
using p
proof (induct p)
  case Nil thus ?case by (simp add: zero_poly_inv)
next
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  with Cons(2) have c: "c  0" and p: "poly_inv p" unfolding poly_inv_def by auto
  from c have c: "poly_inv [(1,c)]" unfolding poly_inv_def monom_inv_def by auto
  show ?case 
    by (simp add: mc, rule poly_add_inv[OF poly_mult_inv[OF c monom_subst_inv[OF sub]] Cons(1)[OF p]])
qed

lemma poly_subst: "eval_poly α (poly_subst σ p) = eval_poly (λ v. eval_poly α (σ v)) p"
  by (induct p, simp add: zero_poly_def, auto simp: field_simps)

lemma eval_poly_subst: 
  assumes eq: " w. f w = eval_poly g (q w)"
  shows "eval_poly f p = eval_poly g (poly_subst q p)" 
proof (induct p)
  case Nil thus ?case by (simp add: zero_poly_def)
next
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  have id: "eval_monom f m =  eval_monom (λv. eval_poly g (q v)) m"
  proof (transfer fixing: f g q, clarsimp)
    fix m
    show "eval_monom_list f m = eval_monom_list (λv. eval_poly g (q v)) m"
    proof (induct m)
      case (Cons wp m)
      obtain w p where wp: "wp = (w,p)" by (cases wp, auto)
      show ?case
        by (simp add: wp Cons eq)
    qed simp
  qed
  show ?case
    by (simp add: mc Cons id, simp add: field_simps)
qed

lift_definition monom_vars_list :: "'v :: linorder monom  'v list" is "map fst" .

lemma monom_vars_list_subst: assumes " w. w  set (monom_vars_list m)  f w = g w" 
  shows "monom_subst f m = monom_subst g m" 
  unfolding monom_subst_def using assms
proof (transfer fixing: f g)
  fix m :: "'a monom_list" 
  assume eq: "w. w  set (map fst m)  f w = g w" 
  thus "monom_list_subst f m = monom_list_subst g m" 
  proof (induct m)
    case (Cons wn m)
    hence rec: "monom_list_subst f m = monom_list_subst g m" and eq: "f (fst wn) = g (fst wn)" by auto
    show ?case
    proof (cases wn)
      case (Pair w n)
      with eq rec show ?thesis by auto
    qed
  qed simp
qed

lemma eval_monom_vars_list: assumes " x. x  set (monom_vars_list xs)  α x = β x"
  shows "eval_monom α xs = eval_monom β xs" using assms
proof (transfer fixing: α β)
  fix xs :: "'a monom_list" 
  assume eq: "w. w  set (map fst xs)  α w = β w" 
  thus "eval_monom_list α xs = eval_monom_list β xs" 
  proof (induct xs)
    case (Cons xi xs)
    hence IH: "eval_monom_list α xs = eval_monom_list β xs" by auto
    obtain x i where xi: "xi = (x,i)" by force
    from Cons(2) xi have "α x = β x" by auto
    with IH show ?case unfolding xi by auto
  qed simp
qed

definition monom_vars where "monom_vars m = set (monom_vars_list m)" 

lemma monom_vars_list_1[simp]: "monom_vars_list 1 = []" 
  by transfer auto

lemma monom_vars_list_var_monom[simp]: "monom_vars_list (var_monom x) = [x]" 
  by transfer auto

lemma monom_vars_eval_monom: 
  "( x. x  monom_vars m  f x = g x)  eval_monom f m = eval_monom g m"
  by (rule eval_monom_vars_list, auto simp: monom_vars_def)


(* the list of variables occurring in p *)
definition poly_vars_list :: "('v :: linorder,'a)poly  'v list" where 
  "poly_vars_list p = remdups (concat (map (monom_vars_list o fst) p))"

definition poly_vars :: "('v :: linorder,'a)poly  'v set" where 
  "poly_vars p = set (concat (map (monom_vars_list o fst) p))"

lemma poly_vars_list[simp]: "set (poly_vars_list p) = poly_vars p" 
  unfolding poly_vars_list_def poly_vars_def by auto

lemma poly_vars: assumes eq: " w. w  poly_vars p  f w = g w"
  shows "poly_subst f p = poly_subst g p" 
using eq
proof (induct p)
  case (Cons mc p)
  hence rec: "poly_subst f p = poly_subst g p" unfolding poly_vars_def by auto
  show ?case
  proof (cases mc)
    case (Pair m c)
    with Cons(2) have " w. w  set (monom_vars_list m)  f w = g w" unfolding poly_vars_def by auto
    hence "monom_subst f m = monom_subst g m"
      by (rule monom_vars_list_subst)
    with rec Pair show ?thesis by auto
  qed
qed simp

lemma poly_var: assumes pv: "v  poly_vars p" and diff: " w. v  w  f w = g w"
  shows "poly_subst f p = poly_subst g p"
proof (rule poly_vars)
  fix w
  assume "w  poly_vars p"
  thus "f w = g w" using pv diff by (cases "v = w", auto)
qed


lemma eval_poly_vars: assumes " x. x  poly_vars p  α x = β x"
  shows "eval_poly α p = eval_poly β p"
using assms
proof (induct p)
  case Nil thus ?case by simp
next
  case (Cons m p)
  from Cons(2) have " x. x  poly_vars p  α x = β x" unfolding poly_vars_def by auto
  from Cons(1)[OF this] have IH: "eval_poly α p = eval_poly β p" .
  obtain xs c where m: "m = (xs,c)" by force
  from Cons(2) have " x. x  set (monom_vars_list xs)  α x = β x" unfolding poly_vars_def m by auto
  hence "eval_monom α xs = eval_monom β xs"
    by (rule eval_monom_vars_list)
  thus ?case unfolding eval_poly.simps IH m by auto
qed

           
declare poly_subst.simps[simp del]



subsection ‹
  Polynomial orders
›

definition pos_assign :: "('v,'a :: ordered_semiring_0)assign  bool"
where "pos_assign α = ( x. α x  0)"

definition poly_ge :: "('v :: linorder,'a :: poly_carrier)poly  ('v,'a)poly  bool" (infix "≥p" 51)
where "p ≥p q = ( α. pos_assign α  eval_poly α p  eval_poly α q)"

lemma poly_ge_refl[simp]: "p ≥p p"
unfolding poly_ge_def using ge_refl by auto

lemma poly_ge_trans[trans]: "p1 ≥p p2; p2 ≥p p3  p1 ≥p p3"
unfolding poly_ge_def using ge_trans by blast


lemma pos_assign_monom_list: fixes α :: "('v :: linorder, 'a :: poly_carrier)assign"
  assumes pos: "pos_assign α"
  shows "eval_monom_list α m  0"
proof (induct m)
  case Nil thus ?case by (simp add: one_ge_zero)
next
  case (Cons xp m)
  show ?case
  proof (cases xp)
    case (Pair x p)
    from pos[unfolded pos_assign_def] have ge: "α x  0" by simp
    have ge: "α x ^ p  0"
    proof (induct p)
      case 0 thus ?case by (simp add: one_ge_zero)
    next
      case (Suc p)
      from ge_trans[OF times_left_mono[OF ge Suc] times_right_mono[OF ge_refl ge]]
      show ?case by (simp add: field_simps)
    qed
    from ge_trans[OF times_right_mono[OF Cons ge] times_left_mono[OF ge_refl Cons]]
    show ?thesis
      by (simp add: Pair)
  qed
qed

lemma pos_assign_monom: fixes α :: "('v :: linorder, 'a :: poly_carrier)assign"
  assumes pos: "pos_assign α"
  shows "eval_monom α m  0"
  by (transfer fixing: α, rule pos_assign_monom_list[OF pos])


lemma pos_assign_poly:   assumes pos: "pos_assign α"
  and p: "p ≥p zero_poly"
  shows "eval_poly α p  0"
proof -
  from p[unfolded poly_ge_def zero_poly_def] pos 
  show ?thesis by auto
qed


lemma poly_add_ge_mono: assumes "p1 ≥p p2" shows "poly_add p1 q ≥p poly_add p2 q"
using assms unfolding poly_ge_def by (auto simp: field_simps plus_left_mono)

lemma poly_mult_ge_mono: assumes "p1 ≥p p2" and "q ≥p zero_poly"
  shows "poly_mult p1 q ≥p poly_mult p2 q"
using assms unfolding poly_ge_def zero_poly_def by (auto simp: times_left_mono)

context poly_order_carrier
begin

definition poly_gt :: "('v :: linorder,'a)poly  ('v,'a)poly  bool" (infix ">p" 51)
where "p >p q = ( α. pos_assign α  eval_poly α p  eval_poly α q)"

lemma poly_gt_imp_poly_ge: "p >p q  p ≥p q" unfolding poly_ge_def poly_gt_def using gt_imp_ge by blast

abbreviation poly_GT :: "('v :: linorder,'a)poly rel"
where "poly_GT  {(p,q) | p q. p >p q  q ≥p zero_poly}"

lemma poly_compat: "p1 ≥p p2; p2 >p p3  p1 >p p3"
unfolding poly_ge_def poly_gt_def using compat by blast

lemma poly_compat2: "p1 >p p2; p2 ≥p p3  p1 >p p3"
unfolding poly_ge_def poly_gt_def using compat2 by blast

lemma poly_gt_trans[trans]: "p1 >p p2; p2 >p p3  p1 >p p3"
unfolding poly_gt_def using gt_trans by blast

lemma poly_GT_SN: "SN poly_GT"
proof
  fix f :: "nat  ('c :: linorder,'a)poly"
  assume f: " i. (f i, f (Suc i))  poly_GT"
  have pos: "pos_assign ((λ x. 0) :: ('v,'a)assign)" (is "pos_assign ?ass") unfolding pos_assign_def using ge_refl by auto
  obtain g where g: " i. g i = eval_poly ?ass (f i)" by auto
  from f pos have " i. g (Suc i)  0  g i  g (Suc i)" unfolding poly_gt_def g using pos_assign_poly by auto
  with SN show False unfolding SN_defs by blast 
qed
end

text ‹monotonicity of polynomials›

lemma eval_monom_list_mono: assumes fg: " x. (f :: ('v :: linorder,'a :: poly_carrier)assign) x  g x" 
  and g: " x. g x  0"
  shows "eval_monom_list f m  eval_monom_list g m" "eval_monom_list g m  0"
proof (atomize(full), induct m)
  case Nil show ?case using one_ge_zero by (auto simp: ge_refl)
next
  case (Cons xd m)
  hence IH1: " eval_monom_list f m  eval_monom_list g m" and IH2: "eval_monom_list g m  0" by auto
  obtain x d where xd: "xd = (x,d)" by force
  from pow_mono[OF fg g, of x d] have fgd: "f x ^ d  g x ^ d" and gd: "g x ^ d  0" by auto
  show ?case unfolding xd eval_monom_list.simps
  proof (rule conjI, rule ge_trans[OF times_left_mono[OF pow_ge_zero IH1] times_right_mono[OF IH2 fgd]])
    show "f x  0" by (rule ge_trans[OF fg g])
    show "eval_monom_list g m * g x ^ d  0"
      by (rule mult_ge_zero[OF IH2 gd])
  qed
qed

lemma eval_monom_mono: assumes fg: " x. (f :: ('v :: linorder,'a :: poly_carrier)assign) x  g x" 
  and g: " x. g x  0"
shows "eval_monom f m  eval_monom g m" "eval_monom g m  0"
  by (atomize(full), transfer fixing: f g, insert eval_monom_list_mono[of g f, OF fg g], auto)


definition poly_weak_mono_all :: "('v :: linorder,'a :: poly_carrier)poly  bool" where 
  "poly_weak_mono_all p   (α :: ('v,'a)assign) β. ( x. α x  β x) 
     pos_assign β  eval_poly α p  eval_poly β p"

lemma poly_weak_mono_all_E: assumes p: "poly_weak_mono_all p" and 
  ge: " x. f x ≥p g x  g x ≥p zero_poly"
  shows "poly_subst f p ≥p poly_subst g p"
  unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_mono_all_def, rule_format])
  fix α :: "('c,'b)assign" and x
  show "pos_assign α  eval_poly α (f x)  eval_poly α (g x)" using ge[of x] unfolding poly_ge_def by auto
next
  fix α :: "('c,'b)assign"
  assume alpha: "pos_assign α"
  show "pos_assign (λv. eval_poly α (g v))" 
    unfolding pos_assign_def
  proof
    fix x
    show "eval_poly α (g x)  0"
    using ge[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
  qed
qed

definition poly_weak_mono :: "('v :: linorder,'a :: poly_carrier)poly  'v  bool" where 
  "poly_weak_mono p v   (α :: ('v,'a)assign) β. ( x. v  x  α x = β x)  pos_assign β  α v  β v  eval_poly α p  eval_poly β p"

lemma poly_weak_mono_E: assumes p: "poly_weak_mono p v"
  and fgw: " w. v  w  f w = g w"
  and g: " w. g w ≥p zero_poly" 
  and fgv: "f v ≥p g v"
  shows "poly_subst f p ≥p poly_subst g p"
  unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_mono_def, rule_format])
  fix α :: "('c,'b)assign"
  show "pos_assign α  eval_poly α (f v)  eval_poly α (g v)" using fgv unfolding poly_ge_def by auto
next
  fix α :: "('c,'b)assign"
  assume alpha: "pos_assign α"
  show "pos_assign (λv. eval_poly α (g v))" 
    unfolding pos_assign_def
  proof
    fix x
    show "eval_poly α (g x)  0"
    using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
  qed
next
  fix α :: "('c,'b)assign" and x
  assume v: "v  x"
  show "pos_assign α  eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed

definition poly_weak_anti_mono :: "('v :: linorder,'a :: poly_carrier)poly  'v  bool" where 
  "poly_weak_anti_mono p v   (α :: ('v,'a)assign) β. ( x. v  x  α x = β x)  pos_assign β  α v  β v  eval_poly β p  eval_poly α p"

lemma poly_weak_anti_mono_E: assumes p: "poly_weak_anti_mono p v"
  and fgw: " w. v  w  f w = g w"
  and g: " w. g w ≥p zero_poly" 
  and fgv: "f v ≥p g v"
  shows "poly_subst g p ≥p poly_subst f p"
  unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_anti_mono_def, rule_format])
  fix α :: "('c,'b)assign"
  show "pos_assign α  eval_poly α (f v)  eval_poly α (g v)" using fgv unfolding poly_ge_def by auto
next
  fix α :: "('c,'b)assign"
  assume alpha: "pos_assign α"
  show "pos_assign (λv. eval_poly α (g v))" 
    unfolding pos_assign_def
  proof
    fix x
    show "eval_poly α (g x)  0"
    using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
  qed
next
  fix α :: "('c,'b)assign" and x
  assume v: "v  x"
  show "pos_assign α  eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed

lemma poly_weak_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes mono: " v. v  poly_vars p  poly_weak_mono p v"
  shows "poly_weak_mono_all p"
unfolding poly_weak_mono_all_def
proof (intro allI impI)
  fix α β :: "('v,'a)assign"
  assume all: " x. α x  β x"
  assume pos: "pos_assign β"
  let ?ab = "λ vs v. if (v  set vs) then α v else β v"
  {
    fix vs :: "'v list"
    assume "set vs  poly_vars p"
    hence "eval_poly (?ab vs) p  eval_poly β p"
    proof (induct vs)
      case Nil show ?case by (simp add: ge_refl)
    next
      case (Cons v vs)
      hence subset: "set vs  poly_vars p"  and v: "v  poly_vars p" by auto
      show ?case
      proof (rule ge_trans[OF mono[OF v, unfolded poly_weak_mono_def, rule_format] Cons(1)[OF subset]])
        show "pos_assign (?ab vs)" unfolding pos_assign_def
        proof
          fix x
          from pos[unfolded pos_assign_def] have beta: "β x  0" by simp
          from ge_trans[OF all[rule_format] this] have alpha: "α x  0" .
          from alpha beta show "?ab vs x  0" by auto
        qed
        show "(?ab (v # vs) v)  (?ab vs v)" using all ge_refl by auto
      next
        fix x
        assume "v  x"
        thus "(?ab (v # vs) x) = (?ab vs x)" by simp
      qed
    qed
  }
  from this[of "poly_vars_list p", unfolded poly_vars_list]
  have "eval_poly (λv. if v  poly_vars p then α v else β v) p  eval_poly β p" by auto
  also have "eval_poly (λv. if v  poly_vars p then α v else β v) p = eval_poly α p"
    by (rule eval_poly_vars, auto)
  finally
  show "eval_poly α p  eval_poly β p" .
qed  

lemma poly_weak_mono_all: fixes p :: "('v :: linorder,'a :: poly_carrier)poly" 
  assumes p: "poly_weak_mono_all p"
  shows "poly_weak_mono p v"
unfolding poly_weak_mono_def
proof (intro allI impI)
  fix α β :: "('v,'a)assign"
  assume all: "x. v  x  α x = β x"
  assume pos: "pos_assign β"
  assume v: "α v  β v"
  show "eval_poly α p  eval_poly β p" 
  proof (rule p[unfolded poly_weak_mono_all_def, rule_format, OF _ pos])
    fix x 
    show "α x  β x"
    using v all ge_refl[of "β x"] by auto
  qed
qed

lemma poly_weak_mono_all_pos: 
  fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes pos_at_zero: "eval_poly (λ w. 0) p  0"
  and mono: "poly_weak_mono_all p"
  shows "p ≥p zero_poly"
unfolding poly_ge_def zero_poly_def
proof (intro allI impI, simp)
  fix  α :: "('v,'a)assign"
  assume pos: "pos_assign α"
  show "eval_poly α p  0"
  proof -
    let ?id = "λ w. poly_of (PVar w)"
    let ?z = "λ w. zero_poly"
    have "poly_subst ?id p ≥p poly_subst ?z p" 
      by (rule poly_weak_mono_all_E[OF mono],  
        simp, simp add: poly_ge_def zero_poly_def pos_assign_def) 
    hence "eval_poly α (poly_subst ?id p)  eval_poly α (poly_subst ?z p)" (is "_  ?res")
      unfolding poly_ge_def using pos by simp
    also have "?res = eval_poly (λ w. 0) p" by (simp add: poly_subst zero_poly_def)
    also have "  0" by (rule pos_at_zero)
    finally show ?thesis by  (simp add: poly_subst)
  qed
qed

context poly_order_carrier
begin

definition poly_strict_mono :: "('v :: linorder,'a)poly  'v  bool" where 
  "poly_strict_mono p v   (α :: ('v,'a)assign) β. ( x. (v  x  α x = β x))  pos_assign β  α v  β v  eval_poly α p  eval_poly β p"

lemma poly_strict_mono_E: assumes p: "poly_strict_mono p v"
  and fgw: " w. v  w  f w = g w"
  and g: " w. g w ≥p zero_poly" 
  and fgv: "f v >p g v"
  shows "poly_subst f p >p poly_subst g p"
  unfolding poly_gt_def poly_subst
proof (intro allI impI, rule p[unfolded poly_strict_mono_def, rule_format])
  fix α :: "('c,'a)assign"
  show "pos_assign α  eval_poly α (f v)  eval_poly α (g v)" using fgv unfolding poly_gt_def by auto
next
  fix α :: "('c,'a)assign"
  assume alpha: "pos_assign α"
  show "pos_assign (λv. eval_poly α (g v))" 
    unfolding pos_assign_def
  proof
    fix x
    show "eval_poly α (g x)  0"
    using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
  qed
next
  fix α :: "('c,'a)assign" and x
  assume v: "v  x"
  show "pos_assign α  eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed

lemma poly_add_gt_mono: assumes "p1 >p p2" shows "poly_add p1 q >p poly_add p2 q"
using assms unfolding poly_gt_def by (auto simp: field_simps plus_gt_left_mono)

lemma poly_mult_gt_mono: 
  fixes q :: "('v :: linorder,'a)poly"
  assumes gt: "p1 >p p2" and mono: "q ≥p one_poly"
  shows "poly_mult p1 q >p poly_mult p2 q"
proof (unfold poly_gt_def, intro impI allI)
  fix α :: "('v,'a)assign"
  assume p: "pos_assign α"
  with gt have gt: "eval_poly α p1  eval_poly α p2" unfolding poly_gt_def by simp
  from mono p have one: "eval_poly α q  1" unfolding poly_ge_def one_poly_def by auto
  show "eval_poly α (poly_mult p1 q)  eval_poly α (poly_mult p2 q)"
    using times_gt_mono[OF gt one] by simp
qed
end

subsection ‹Degree of polynomials›

definition monom_list_degree :: "'v monom_list  nat" where 
  "monom_list_degree xps  sum_list (map snd xps)"

lift_definition monom_degree :: "'v :: linorder monom  nat" is monom_list_degree .

definition poly_degree :: "(_,'a) poly  nat" where
  "poly_degree p  max_list (map (λ (m,c). monom_degree m) p)"

definition poly_coeff_sum :: "('v,'a :: ordered_ab_semigroup) poly  'a" where
  "poly_coeff_sum p  sum_list (map (λ mc. max 0 (snd mc)) p)"

lemma monom_list_degree: "eval_monom_list (λ _. x) m = x ^ monom_list_degree m"
  unfolding monom_list_degree_def
proof (induct m)
  case Nil show ?case by simp
next 
  case (Cons mc m)
  thus ?case by (cases mc, auto simp: power_add field_simps)
qed

lemma monom_list_var_monom[simp]: "monom_list (var_monom x) = [(x,1)]" 
  by (transfer, simp)

lemma monom_list_1[simp]: "monom_list 1 = []" 
  by (transfer, simp)

lemma monom_degree: "eval_monom (λ _. x) m = x ^ monom_degree m"
  by (transfer, rule monom_list_degree)

lemma poly_coeff_sum: "poly_coeff_sum p  0"
  unfolding poly_coeff_sum_def
proof (induct p)
  case Nil show ?case by (simp add: ge_refl)
next
  case (Cons mc p)
  have "(mcmc # p. max 0 (snd mc)) = max 0 (snd mc) + (mcp. max 0 (snd mc))" by auto
  also have "  0 + 0"
    by (rule ge_trans[OF plus_left_mono plus_right_mono[OF Cons]], auto)
  finally show ?case by simp
qed

lemma poly_degree: assumes x: "x  (1 :: 'a :: poly_carrier)" 
  shows "poly_coeff_sum p * (x ^ poly_degree p)  eval_poly (λ _. x) p"
proof (induct p)
  case Nil show ?case by (simp add: ge_refl poly_degree_def poly_coeff_sum_def)
next
  case (Cons mc p)  
  obtain m c where mc: "mc = (m,c)" by force
  from ge_trans[OF x one_ge_zero] have x0: "x  0" .
  have id1: "eval_poly (λ_. x) (mc # p) = x ^ monom_degree m  * c + eval_poly (λ_. x) p" unfolding mc by (simp add: monom_degree)
  have id2: "poly_coeff_sum (mc # p) * x ^ poly_degree (mc # p) = 
    x ^ max (monom_degree m) (poly_degree p) * (max 0 c) + poly_coeff_sum p * x ^ max (monom_degree m) (poly_degree p)"
    unfolding poly_coeff_sum_def poly_degree_def by (simp add: mc field_simps)
  show "poly_coeff_sum (mc # p) * x ^ poly_degree (mc # p)  eval_poly (λ_. x) (mc # p)"
    unfolding id1 id2
  proof (rule ge_trans[OF plus_left_mono plus_right_mono])
    show "x ^ max (monom_degree m) (poly_degree p) * max 0 c  x ^ monom_degree m * c"
      by (rule ge_trans[OF times_left_mono[OF _ pow_mono_exp] times_right_mono[OF pow_ge_zero]], insert x x0, auto)
    show "poly_coeff_sum p * x ^ max (monom_degree m) (poly_degree p)  eval_poly (λ_. x) p"
      by (rule ge_trans[OF times_right_mono[OF poly_coeff_sum pow_mono_exp[OF x]] Cons], auto)
  qed
qed

lemma poly_degree_bound: assumes x: "x  (1 :: 'a :: poly_carrier)" 
  and c: "c  poly_coeff_sum p"
  and d: "d  poly_degree p"
  shows "c * (x ^ d)  eval_poly (λ _. x) p"
  by (rule ge_trans[OF ge_trans[OF 
    times_left_mono[OF pow_ge_zero[OF ge_trans[OF x one_ge_zero]] c]   
    times_right_mono[OF poly_coeff_sum pow_mono_exp[OF x d]]] poly_degree[OF x]])


subsection ‹Executable and sufficient criteria to compare polynomials and ensure monotonicity› 

text ‹poly\_split extracts the coefficient for a given monomial and returns additionally the remaining polynomial›
definition poly_split :: "('v monom)  ('v,'a :: zero)poly  'a × ('v,'a)poly" 
  where "poly_split m p  case List.extract (λ (n,_). m = n) p of None  (0,p) | Some (p1,(_,c),p2)  (c, p1 @ p2)"

lemma poly_split: assumes "poly_split m p = (c,q)"
  shows "p =p (m,c) # q"
proof (cases "List.extract (λ (n,_). m = n) p")
  case None
  with assms have "(c,q) = (0,p)" unfolding poly_split_def by auto
  thus ?thesis unfolding eq_poly_def by auto
next
  case (Some res)
  obtain p1 mc p2 where "res = (p1,mc,p2)" by (cases res, auto)
  with extract_SomeE[OF Some[simplified this]] obtain a where p: "p = p1 @ (m,a) # p2" and res: "res = (p1,(m,a),p2)" by (cases mc, auto)
  from Some res assms have c: "c = a" and q: "q = p1 @ p2" unfolding poly_split_def by auto
  show ?thesis unfolding eq_poly_def by (simp add: p c q field_simps)
qed 

lemma poly_split_eval: assumes "poly_split m p = (c,q)" 
  shows "eval_poly α p = (eval_monom α m * c) + eval_poly α q"
using poly_split[OF assms] unfolding eq_poly_def by auto

(* we assume that the polynomial invariant is present, otherwise this check might fail, e.g., on 0 =p 0 + 0 *)
fun check_poly_eq :: "('v,'a :: semiring_0)poly  ('v,'a)poly  bool" where 
  "check_poly_eq [] q = (q = [])"
| "check_poly_eq ((m,c) # p) q = (case List.extract (λ nd. fst nd = m) q of
       None  False
     | Some (q1,(_,d),q2)  c = d  check_poly_eq p (q1 @ q2))"

lemma check_poly_eq: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes chk: "check_poly_eq p q"
  shows "p =p q" unfolding eq_poly_def
proof
  fix α
  from chk show "eval_poly α p = eval_poly α q"
  proof (induct p arbitrary: q)
    case Nil
    thus ?case by auto
  next
    case (Cons mc p)
    obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
    show ?case
    proof (cases "List.extract (λ mc. fst mc = m) q")
      case None
      with Cons(2) show ?thesis unfolding mc by simp
    next
      case (Some res)
      obtain q1 md q2 where "res = (q1,md,q2)" by (cases res, auto)
      with extract_SomeE[OF Some[simplified this]] obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" 
        by (cases md, auto)
      from Cons(2) Some mc res have rec: "check_poly_eq p (q1 @ q2)" and c: "c = d" by auto
      from Cons(1)[OF rec] have p: "eval_poly α p = eval_poly α (q1 @ q2)" .
      show ?thesis unfolding mc eval_poly.simps c p q by (simp add: ac_simps)
    qed
  qed
qed

declare check_poly_eq.simps[simp del]


fun check_poly_ge :: "('v,'a :: ordered_semiring_0)poly  ('v,'a)poly  bool" where 
  "check_poly_ge [] q = list_all (λ (_,d). 0  d) q"
| "check_poly_ge ((m,c) # p) q = (case List.extract (λ nd. fst nd = m) q of
     None  c  0  check_poly_ge p q
   | Some (q1,(_,d),q2)  c  d  check_poly_ge p (q1 @ q2))"

lemma check_poly_ge: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  shows "check_poly_ge p q  p ≥p q"
proof (induct p arbitrary: q)
  case Nil
  hence " (n,d)  set q. 0  d" using list_all_iff[of _ q] by auto
  hence "[] ≥p q" 
  proof (induct q)
    case Nil thus ?case by (simp)
  next
    case (Cons nd q)
    hence rec: "[] ≥p q" by simp
    show ?case
    proof (cases nd)
      case (Pair n d)
      with Cons have ge: "0  d" by auto
      show ?thesis 
      proof (simp only: Pair, unfold poly_ge_def, intro allI impI)
        fix α :: "('v,'a)assign"
        assume pos: "pos_assign α"
        have ge: "0  eval_monom α n * d"
          using times_right_mono[OF pos_assign_monom[OF pos, of n] ge] by simp
        from rec[unfolded poly_ge_def] pos have ge2: "0  eval_poly α q" by auto
        show "eval_poly α []  eval_poly α ((n,d) # q)" using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF ge2]]
          by simp
      qed
    qed
  qed
  thus ?case by simp
next
  case (Cons mc p)
  obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
  show ?case
  proof (cases "List.extract (λ mc. fst mc = m) q")
    case None
    with Cons(2) have rec: "check_poly_ge p q" and c: "c  0" using mc by auto
    from Cons(1)[OF rec] have rec: "p ≥p q" .
    show ?thesis 
    proof (simp only: mc, unfold poly_ge_def, intro allI impI)
      fix α :: "('v,'a)assign"
      assume pos: "pos_assign α"
      have ge: "eval_monom α m * c  0"
        using times_right_mono[OF pos_assign_monom[OF pos, of m] c] by simp
      from rec have pq: "eval_poly α p  eval_poly α q" unfolding poly_ge_def using pos by auto
      show "eval_poly α ((m,c) # p)  eval_poly α q"
        using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF pq]] by simp
    qed
  next
    case (Some res)
    obtain q1 md q2 where "res = (q1,md,q2)" by (cases res, auto)
    with extract_SomeE[OF Some[simplified this]] obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" 
      by (cases md, auto)
    from Cons(2) Some mc res have rec: "check_poly_ge p (q1 @ q2)" and c: "c  d" by auto
    from Cons(1)[OF rec] have p: "p ≥p q1 @ q2" .
    show ?thesis
    proof (simp only: mc, unfold poly_ge_def, intro allI impI)
      fix α :: "('v,'a)assign"
      assume pos: "pos_assign α"
      have ge: "eval_monom α m * c  eval_monom α m * d"
        using times_right_mono[OF pos_assign_monom[OF pos, of m] c] 
          by simp
      from p have ge2: "eval_poly α p  eval_poly α (q1 @ q2)" unfolding poly_ge_def using pos by auto
      show "eval_poly α ((m,c) # p)  eval_poly α q" using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF ge2]]
        by (simp add: q field_simps)
    qed
  qed
qed

declare check_poly_ge.simps[simp del]

definition check_poly_weak_mono_all :: "('v,'a :: ordered_semiring_0)poly  bool"
where "check_poly_weak_mono_all p  list_all (λ (m,c). c  0) p"

lemma check_poly_weak_mono_all: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes "check_poly_weak_mono_all p" shows  "poly_weak_mono_all p"
unfolding poly_weak_mono_all_def
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume fg: " x. f x  g x"
  and pos: "pos_assign g"
  hence fg: " x. f x  g x" by auto
  from pos[unfolded pos_assign_def] have g: " x. g x  0" ..
  from assms have " m c. (m,c)  set p  c  0" unfolding check_poly_weak_mono_all_def by (auto simp: list_all_iff)
  thus "eval_poly f p  eval_poly g p"
  proof (induct p)
    case Nil thus ?case by (simp add: ge_refl)
  next
    case (Cons mc p)
    hence IH: "eval_poly f p  eval_poly g p" by auto
    show ?case 
    proof (cases mc)
      case (Pair m c)
      with Cons have c: "c  0" by auto
      show ?thesis unfolding Pair eval_poly.simps fst_conv snd_conv
      proof (rule ge_trans[OF plus_left_mono[OF times_left_mono[OF c]] plus_right_mono[OF IH]])
        show "eval_monom f m  eval_monom g m"
          by (rule eval_monom_mono(1)[OF fg g])
      qed
    qed
  qed
qed

lemma check_poly_weak_mono_all_pos: 
  assumes "check_poly_weak_mono_all p" shows  "p ≥p zero_poly"
unfolding zero_poly_def
proof (rule check_poly_ge)
  from assms have " m c. (m,c)  set p  c  0" unfolding check_poly_weak_mono_all_def by (auto simp: list_all_iff)
  thus "check_poly_ge p []"
    by (induct p, simp add: check_poly_ge.simps,  clarify, auto simp: check_poly_ge.simps extract_Nil_code)
qed


text ‹better check for weak monotonicity for discrete carriers: 
   $p$ is monotone in $v$ if $p(\ldots v+1 \ldots) \geq p(\ldots v \ldots)$›
definition check_poly_weak_mono_discrete :: "('v :: linorder,'a :: poly_carrier)poly  'v  bool"
  where "check_poly_weak_mono_discrete p v  check_poly_ge (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p"

definition check_poly_weak_mono_and_pos :: "bool  ('v :: linorder,'a :: poly_carrier)poly  bool"
  where "check_poly_weak_mono_and_pos discrete p  
            if discrete then list_all (λ v. check_poly_weak_mono_discrete p v) (poly_vars_list p)  eval_poly (λ w. 0) p   0
                        else check_poly_weak_mono_all p"

definition check_poly_weak_anti_mono_discrete :: "('v :: linorder,'a :: poly_carrier)poly  'v  bool"
  where "check_poly_weak_anti_mono_discrete p v  check_poly_ge p (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p)"

context poly_order_carrier
begin

lemma check_poly_weak_mono_discrete: 
  fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
  assumes discrete and check: "check_poly_weak_mono_discrete p v"
  shows "poly_weak_mono p v"
unfolding poly_weak_mono_def 
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume fgw: " w. (v  w  f w = g w)"
  and gass: "pos_assign g"
  and v: "f v  g v"
  from fgw have w: " w. v  w  f w = g w" by auto
  from assms check_poly_ge have ge: "poly_ge (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p" (is "poly_ge ?p1 p") unfolding check_poly_weak_mono_discrete_def by blast
  from discrete[OF discrete v] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
  show "eval_poly f p  eval_poly g p"
  proof (cases k')
    case 0
    {
      fix x
      have "f x = g x" using id 0 w by (cases "x = v", auto)
    }
    hence "f = g" ..
    thus ?thesis using ge_refl by simp
  next
    case (Suc k)
    with id have "f v = (((+) 1)^^(Suc k))  (g v)" by simp 
    with w gass show "eval_poly f p  eval_poly g p"
    proof (induct k arbitrary: f g rule: less_induct)
      case (less k)
      show ?case 
      proof (cases k)
        case 0
        with less have id0: "f v = 1 + g v" by simp
        have id1: "eval_poly f p = eval_poly g ?p1"
        proof (rule eval_poly_subst)
          fix w
          show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
          proof (cases "w = v")
            case True
            show ?thesis by (simp add: True id0 zero_poly_def)
          next
            case False
            with less have "f w = g w" by simp
            thus ?thesis by (simp add: False)
          qed
        qed
        have "eval_poly g ?p1  eval_poly g p" using ge less unfolding poly_ge_def by simp
        with id1 show ?thesis by simp
      next
        case (Suc kk)        
        obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
        have "(1 :: 'a) + g v  1 + 0" 
          by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
        also have "1 + (0 :: 'a) = 1" by simp
        also have "  0" by (rule one_ge_zero)
        finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def 
          by (simp add: g')
        {
          fix w
          assume "v  w"
          hence "f w = g' w"
            unfolding g' by (simp add: less)
        } note w = this
        have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
          by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
        from Suc have kk: "kk < k" by simp
        from less(1)[OF kk w g'pos] eq
        have rec1: "eval_poly f p  eval_poly g' p" by simp
        { 
          fix w
          assume "v  w"
          hence "g' w = g w"
            unfolding g' by simp
        } note w = this
        from Suc have z: "0 < k" by simp
        from less(1)[OF z w less(3)] g'
        have rec2: "eval_poly g' p  eval_poly g p" by simp
        show ?thesis by (rule ge_trans[OF rec1 rec2])
      qed
    qed
  qed
qed

lemma check_poly_weak_anti_mono_discrete: 
  fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
  assumes discrete and check: "check_poly_weak_anti_mono_discrete p v"
  shows "poly_weak_anti_mono p v"
unfolding poly_weak_anti_mono_def 
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume fgw: " w. (v  w  f w = g w)"
  and gass: "pos_assign g"
  and v: "f v  g v"
  from fgw have w: " w. v  w  f w = g w" by auto
  from assms check_poly_ge have ge: "poly_ge p (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p)" (is "poly_ge p ?p1") unfolding check_poly_weak_anti_mono_discrete_def by blast
  from discrete[OF discrete v] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
  show "eval_poly g p  eval_poly f p"
  proof (cases k')
    case 0
    {
      fix x
      have "f x = g x" using id 0 w by (cases "x = v", auto)
    }
    hence "f = g" ..
    thus ?thesis using ge_refl by simp
  next
    case (Suc k)
    with id have "f v = (((+) 1)^^(Suc k))  (g v)" by simp 
    with w gass show "eval_poly g p  eval_poly f p"
    proof (induct k arbitrary: f g rule: less_induct)
      case (less k)
      show ?case 
      proof (cases k)
        case 0
        with less have id0: "f v = 1 + g v" by simp
        have id1: "eval_poly f p = eval_poly g ?p1"
        proof (rule eval_poly_subst)
          fix w
          show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
          proof (cases "w = v")
            case True
            show ?thesis by (simp add: True id0 zero_poly_def)
          next
            case False
            with less have "f w = g w" by simp
            thus ?thesis by (simp add: False)
          qed
        qed
        have "eval_poly g p  eval_poly g ?p1" using ge less unfolding poly_ge_def by simp
        with id1 show ?thesis by simp
      next
        case (Suc kk)        
        obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
        have "(1 :: 'a) + g v  1 + 0" 
          by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
        also have "(1 :: 'a) + 0 = 1" by simp
        also have "  0" by (rule one_ge_zero)
        finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def 
          by (simp add: g')
        {
          fix w
          assume "v  w"
          hence "f w = g' w"
            unfolding g' by (simp add: less)
        } note w = this
        have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
          by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
        from Suc have kk: "kk < k" by simp
        from less(1)[OF kk w g'pos] eq
        have rec1: "eval_poly g' p  eval_poly f p" by simp
        { 
          fix w
          assume "v  w"
          hence "g' w = g w"
            unfolding g' by simp
        } note w = this
        from Suc have z: "0 < k" by simp
        from less(1)[OF z w less(3)] g'
        have rec2: "eval_poly g p  eval_poly g' p" by simp
        show ?thesis by (rule ge_trans[OF rec2 rec1])
      qed
    qed
  qed
qed

lemma check_poly_weak_mono_and_pos: 
  fixes p :: "('v :: linorder,'a)poly"
  assumes "check_poly_weak_mono_and_pos discrete p"
  shows "poly_weak_mono_all p  (p ≥p zero_poly)"
proof (cases discrete)
  case False
  with assms have c: "check_poly_weak_mono_all p" unfolding check_poly_weak_mono_and_pos_def
    by auto
  from check_poly_weak_mono_all[OF c] check_poly_weak_mono_all_pos[OF c] show ?thesis by auto
next
  case True
  with assms have c: "list_all (λ v. check_poly_weak_mono_discrete p v) (poly_vars_list p)" and g: "eval_poly (λ w. 0) p  0"
    unfolding check_poly_weak_mono_and_pos_def by auto
  have m: "poly_weak_mono_all p"
  proof (rule poly_weak_mono)
    fix v :: 'v
    assume v: "v  poly_vars p"
    show "poly_weak_mono p v"
      by (rule check_poly_weak_mono_discrete[OF True], insert c[unfolded list_all_iff] v, auto)  
  qed
  have m': "poly_weak_mono_all  p"
  proof (rule poly_weak_mono)
    fix v :: 'v
    assume v: "v  poly_vars p"
    show "poly_weak_mono p v"
      by (rule check_poly_weak_mono_discrete[OF True], insert c[unfolded list_all_iff] v, auto) 
  qed
  from poly_weak_mono_all_pos[OF g m'] m show ?thesis by auto
qed

end

definition check_poly_weak_mono :: "('v :: linorder,'a :: ordered_semiring_0)poly  'v  bool"
  where "check_poly_weak_mono p v  list_all (λ (m,c). c  0  v  monom_vars m) p"

lemma check_poly_weak_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes "check_poly_weak_mono p v" shows  "poly_weak_mono p v"
unfolding poly_weak_mono_def
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume " x. v  x  f x = g x"
  and pos: "pos_assign g" 
  and ge: "f v  g v"
  hence fg: " x. v  x  f x = g x" by auto
  from pos[unfolded pos_assign_def] have g: " x. g x  0" ..
  from assms have " m c. (m,c)  set p  c  0  v  monom_vars m" unfolding check_poly_weak_mono_def by (auto simp: list_all_iff)
  thus "eval_poly f p  eval_poly g p"
  proof (induct p)
    case (Cons mc p)
    hence IH: "eval_poly f p  eval_poly g p" by auto
    obtain m c where mc: "mc = (m,c)" by force
    with Cons have c: "c  0  v  monom_vars m" by auto
    show ?case unfolding mc eval_poly.simps fst_conv snd_conv
    proof (rule ge_trans[OF plus_left_mono plus_right_mono[OF IH]])
      from c show "eval_monom f m * c  eval_monom g m * c"
      proof
        assume c: "c  0"
        show ?thesis
        proof (rule times_left_mono[OF c], rule eval_monom_mono(1)[OF _ g])
          fix x
          show "f x  g x" using ge fg[of x] by (cases "x = v", auto simp: ge_refl)
        qed
      next
        assume v: "v  monom_vars m"
        have "eval_monom f m = eval_monom g m"
          by (rule monom_vars_eval_monom, insert fg v, fast)
        thus ?thesis by (simp add: ge_refl)        
      qed
    qed
  qed (simp add: ge_refl)
qed

definition check_poly_weak_mono_smart :: "bool  ('v :: linorder,'a :: poly_carrier)poly  'v  bool"
  where "check_poly_weak_mono_smart discrete  if discrete then check_poly_weak_mono_discrete else check_poly_weak_mono"

lemma (in poly_order_carrier) check_poly_weak_mono_smart: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  shows "check_poly_weak_mono_smart discrete p v  poly_weak_mono p v"
  unfolding check_poly_weak_mono_smart_def
  using check_poly_weak_mono check_poly_weak_mono_discrete by (cases discrete, auto)

definition check_poly_weak_anti_mono :: "('v :: linorder,'a :: ordered_semiring_0)poly  'v  bool"
  where "check_poly_weak_anti_mono p v  list_all (λ (m,c). 0  c  v  monom_vars m) p"

lemma check_poly_weak_anti_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  assumes "check_poly_weak_anti_mono p v" shows  "poly_weak_anti_mono p v"
unfolding poly_weak_anti_mono_def
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume " x. v  x  f x = g x"
  and pos: "pos_assign g" 
  and ge: "f v  g v"
  hence fg: " x. v  x  f x = g x" by auto
  from pos[unfolded pos_assign_def] have g: " x. g x  0" ..
  from assms have " m c. (m,c)  set p  0  c  v  monom_vars m" unfolding check_poly_weak_anti_mono_def by (auto simp: list_all_iff)
  thus "eval_poly g p  eval_poly f p"
  proof (induct p)
    case Nil thus ?case by (simp add: ge_refl)
  next
    case (Cons mc p)
    hence IH: "eval_poly g p  eval_poly f p" by auto
    obtain m c where mc: "mc = (m,c)" by force
    with Cons have c: "0  c  v  monom_vars m" by auto
    show ?case unfolding mc eval_poly.simps fst_conv snd_conv
    proof (rule ge_trans[OF plus_left_mono plus_right_mono[OF IH]])
      from c show "eval_monom g m * c  eval_monom f m * c"
      proof
        assume c: "0  c"
        show ?thesis
        proof (rule times_left_anti_mono[OF eval_monom_mono(1)[OF _ g] c])
          fix x
          show "f x  g x" using ge fg[of x] by (cases "x = v", auto simp: ge_refl)
        qed
      next
        assume v: "v  monom_vars m"
        have "eval_monom f m = eval_monom g m"
          by (rule monom_vars_eval_monom, insert fg v, fast)
        thus ?thesis by (simp add: ge_refl)        
      qed
    qed
  qed
qed

definition check_poly_weak_anti_mono_smart :: "bool  ('v :: linorder,'a :: poly_carrier)poly  'v  bool"
  where "check_poly_weak_anti_mono_smart discrete  if discrete then check_poly_weak_anti_mono_discrete else check_poly_weak_anti_mono"

lemma (in poly_order_carrier) check_poly_weak_anti_mono_smart: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
  shows "check_poly_weak_anti_mono_smart discrete p v  poly_weak_anti_mono p v"
  unfolding check_poly_weak_anti_mono_smart_def
  using check_poly_weak_anti_mono[of p v] check_poly_weak_anti_mono_discrete[of p v] 
  by (cases discrete, auto)

definition check_poly_gt :: "('a  'a  bool)  ('v :: linorder,'a :: ordered_semiring_0)poly  ('v,'a)poly  bool"
where "check_poly_gt gt p q  let (a1,p1) = poly_split 1 p; (b1,q1) = poly_split 1 q in gt a1 b1  check_poly_ge p1 q1"

fun univariate_power_list :: "'v  'v monom_list  nat option" where
  "univariate_power_list x [(y,n)] = (if x = y then Some n else None)" 
| "univariate_power_list _ _ = None" 

lemma univariate_power_list: assumes "monom_inv m" "univariate_power_list x m = Some n" 
  shows "sum_var_list m = (λ y. if x = y then n else 0)" 
   "eval_monom_list α m = ((α x)^n)" 
   "n  1" 
proof -
  have m: "m = [(x,n)]" using assms
    by (induct x m rule: univariate_power_list.induct, auto split: if_splits)
  show "eval_monom_list α m = ((α x)^n)" "sum_var_list m = (λ y. if x = y then n else 0)"
    "n  1" using assms(1)
    unfolding m monom_inv_def by (auto simp: sum_var_list_def)
qed

lift_definition univariate_power :: "'v :: linorder  'v monom  nat option" 
  is univariate_power_list .

lemma univariate_power: assumes "univariate_power x m = Some n" 
  shows "sum_var m = (λ y. if x = y then n else 0)" 
   "eval_monom α m = ((α x)^n)"
   "n  1" 
  by (atomize(full), insert assms, transfer, auto dest: univariate_power_list)

lemma univariate_power_var_monom: "univariate_power y (var_monom x) = (if x = y then Some 1 else None)"
  by (transfer, auto)

definition check_monom_strict_mono :: "bool  'v :: linorder monom  'v  bool" where
  "check_monom_strict_mono pm m v  case univariate_power v m of
     Some p  pm  p = 1
   | None  False"

definition check_poly_strict_mono :: "bool  ('v :: linorder, 'a :: poly_carrier)poly  'v  bool"
  where "check_poly_strict_mono pm p v  list_ex (λ (m,c). (c  1)  check_monom_strict_mono pm m v) p"

definition check_poly_strict_mono_discrete :: "('a :: poly_carrier  'a  bool)  ('v :: linorder,'a)poly  'v  bool"
  where "check_poly_strict_mono_discrete gt p v  check_poly_gt gt (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p "

definition check_poly_strict_mono_smart :: "bool  bool  ('a :: poly_carrier  'a  bool)  ('v :: linorder,'a)poly  'v  bool"
  where "check_poly_strict_mono_smart discrete pm gt p v  
            if discrete then check_poly_strict_mono_discrete gt p v else check_poly_strict_mono pm p v"

context poly_order_carrier
begin
lemma check_monom_strict_mono: fixes α β :: "('v :: linorder,'a)assign" and v :: 'v and m :: "'v monom"
  assumes check: "check_monom_strict_mono power_mono m v"
  and gt: "α v  β v"
  and ge: "β v  0"
shows "eval_monom α m  eval_monom β m"
proof -
  from check[unfolded check_monom_strict_mono_def] obtain n where
    uni: "univariate_power v m = Some n" and 1: "¬ power_mono  n = 1" 
    by (auto split: option.splits)
  from univariate_power[OF uni] 
  have n1: "n  1" and eval: "eval_monom a m = a v ^ n" for a :: "('v,'a)assign"
    by auto
  show ?thesis
  proof (cases power_mono)
    case False
    with gt 1[OF this] show ?thesis unfolding eval by auto
  next
    case True
    from power_mono[OF True gt ge n1] show ?thesis unfolding eval .
  qed
qed

lemma check_poly_strict_mono: 
  assumes check1: "check_poly_strict_mono power_mono p v"
  and check2: "check_poly_weak_mono_all p"
  shows "poly_strict_mono p v"
unfolding poly_strict_mono_def
proof (intro allI impI)
  fix f g :: "('b,'a)assign"
  assume fgw: " w. (v  w  f w = g w)"
  and pos: "pos_assign g"
  and fgv: "f v  g v"
  from pos[unfolded pos_assign_def] have g: " x. g x  0" ..
  {
    fix w
    have "f w  g w"
    proof (cases "v = w")
      case False
      with fgw ge_refl show ?thesis by auto
    next
      case True
      from fgv[unfolded True] show ?thesis by (rule gt_imp_ge)
    qed
  } note fgw2 = this
  let ?e = "eval_poly"
  show "?e f p  ?e g p"
    using check1[unfolded check_poly_strict_mono_def, simplified list_ex_iff]
      check2[unfolded check_poly_weak_mono_all_def, simplified list_all_iff, THEN bspec]
  proof (induct p)
    case Nil thus ?case by simp
  next
    case (Cons mc p)
    obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
    show ?case 
    proof (cases "c  1  check_monom_strict_mono power_mono m v")
      case True
      hence c: "c  1" and m: "check_monom_strict_mono power_mono m v" by blast+
      from times_gt_mono[OF check_monom_strict_mono[OF m, of f g, OF fgv g] c]
      have gt: "eval_monom f m * c  eval_monom g m * c" .
      from Cons(3) have "check_poly_weak_mono_all p" unfolding check_poly_weak_mono_all_def list_all_iff by auto
      from check_poly_weak_mono_all[OF this, unfolded poly_weak_mono_all_def, rule_format, OF fgw2 pos]
      have ge: "?e f p  ?e g p" .
      from compat2[OF plus_gt_left_mono[OF gt] plus_right_mono[OF ge]]
      show ?thesis unfolding mc by simp
    next
      case False
      with Cons(2) mc have " mc  set p. (λ (m,c). c  1  check_monom_strict_mono power_mono m v) mc" by auto
      from Cons(1)[OF this] Cons(3) have rec: "?e f p  ?e g p" by simp
      from Cons(3) mc have c: "c  0" by auto
      from times_left_mono[OF c eval_monom_mono(1)[OF fgw2 g]] 
      have ge: "eval_monom f m * c  eval_monom g m * c" .
      from compat2[OF plus_gt_left_mono[OF rec] plus_right_mono[OF ge]]
      show ?thesis by (simp add: mc field_simps)
    qed
  qed 
qed     
      

lemma check_poly_gt: 
  fixes p :: "('v :: linorder,'a)poly"
  assumes "check_poly_gt gt p q" shows "p >p q"
proof -
  obtain a1 p1 where p: "poly_split 1 p = (a1,p1)" by force
  obtain b1 q1 where q: "poly_split 1 q = (b1,q1)" by force
  from p q assms have gt: "a1  b1" and ge: "p1 ≥p q1" unfolding check_poly_gt_def using check_poly_ge[of p1 q1]  by auto
  show ?thesis
  proof (unfold poly_gt_def, intro impI allI)
    fix α :: "('v,'a)assign"
    assume "pos_assign α"
    with ge have ge: "eval_poly α p1  eval_poly α q1" unfolding poly_ge_def by simp
    from plus_gt_left_mono[OF gt] compat[OF plus_left_mono[OF ge]] have gt: "a1 + eval_poly α p1  b1 + eval_poly α q1" by (force simp: field_simps)
    show "eval_poly α p  eval_poly α q"
      by (simp add: poly_split[OF p, unfolded eq_poly_def] poly_split[OF q, unfolded eq_poly_def] gt)
  qed
qed

lemma check_poly_strict_mono_discrete: 
  fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
  assumes discrete and check: "check_poly_strict_mono_discrete gt p v"
  shows "poly_strict_mono p v"
unfolding poly_strict_mono_def 
proof (intro allI impI)
  fix f g :: "('v,'a)assign"
  assume fgw: " w. (v  w  f w = g w)"
  and gass: "pos_assign g"
  and v: "f v  g v"
  from gass have g: " x. g x  0" unfolding pos_assign_def ..
  from fgw have w: " w. v  w  f w = g w" by auto
  from assms check_poly_gt have gt: "poly_gt (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p" (is "poly_gt ?p1 p") unfolding check_poly_strict_mono_discrete_def by blast
  from discrete[OF discrete gt_imp_ge[OF v]] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
  {
    assume "k' = 0"
    from v[unfolded id this] have "g v  g v" by simp
    hence False using SN g[of v] unfolding SN_defs by auto
  }
  with id obtain k where id: "f v = (((+) 1)^^(Suc k)) (g v)" by (cases k', auto)
  with w gass
  show "eval_poly f p  eval_poly g p"
  proof (induct k arbitrary: f g rule: less_induct)
    case (less k)
    show ?case
    proof (cases k)
      case 0
      with less(4) have id0: "f v = 1 + g v" by simp
      have id1: "eval_poly f p = eval_poly g ?p1"
      proof (rule eval_poly_subst)
        fix w
        show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
        proof (cases "w = v")
          case True
          show ?thesis by (simp add: True id0 zero_poly_def)
        next
          case False
          with less have "f w = g w" by simp
          thus ?thesis by (simp add: False)
        qed
      qed
      have "eval_poly g ?p1  eval_poly g p" using gt less unfolding poly_gt_def by simp
      with id1 show ?thesis by simp
    next
      case (Suc kk)        
      obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
      have "(1 :: 'a) + g v  1 + 0" 
        by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
      also have "(1 :: 'a) + 0 = 1" by simp
      also have "  0" by (rule one_ge_zero)
      finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def 
        by (simp add: g')
      {
        fix w
        assume "v  w"
        hence "f w = g' w"
          unfolding g' by (simp add: less)
      } note w = this
      have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
        by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
      from Suc have kk: "kk < k" by simp
      from less(1)[OF kk w g'pos] eq
      have rec1: "eval_poly f p  eval_poly g' p" by simp
      { 
        fix w
        assume "v  w"
        hence "g' w = g w"
          unfolding g' by simp
      } note w = this
      from Suc have z: "0 < k" by simp
      from less(1)[OF z w less(3)] g'
      have rec2: "eval_poly g' p  eval_poly g p" by simp
      show ?thesis by (rule gt_trans[OF rec1 rec2])
    qed
  qed
qed

lemma check_poly_strict_mono_smart: 
  assumes check1: "check_poly_strict_mono_smart discrete power_mono gt p v"
  and check2: "check_poly_weak_mono_and_pos discrete p"
  shows "poly_strict_mono p v"
proof (cases discrete)
  case True
  with check1[unfolded check_poly_strict_mono_smart_def]
    check_poly_strict_mono_discrete[OF True]
  show ?thesis by auto
next
  case False
  from check_poly_strict_mono[OF check1[unfolded check_poly_strict_mono_smart_def, simplified False, simplified]]
    check2[unfolded check_poly_weak_mono_and_pos_def, simplified False, simplified]
  show ?thesis by auto
qed

end

end

Theory Show_Polynomials

(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section ‹Displaying Polynomials›

theory Show_Polynomials
imports 
  Polynomials
  Show.Show_Instances
begin

fun shows_monom_list :: "('v :: {linorder,show})monom_list  string  string" where 
  "shows_monom_list [(x,p)] = (if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p)"
| "shows_monom_list ((x,p) # m) = ((if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p) +@+ shows_string ''*'' +@+ shows_monom_list m)"
| "shows_monom_list [] = shows_string ''1''"

instantiation monom :: ("{linorder,show}") "show" 
begin

lift_definition shows_prec_monom :: "nat  'a monom  shows" is "λ n. shows_monom_list" .

lemma shows_prec_monom_append [show_law_simps]:
  "shows_prec d (m :: 'a monom) (r @ s) = shows_prec d m r @ s"
proof (transfer fixing: d r s)
  fix m :: "'a monom_list"
  show "shows_monom_list m (r @ s) = shows_monom_list m r @ s"
    by (induct m arbitrary: r s rule: shows_monom_list.induct, auto simp: show_law_simps)
qed

definition "shows_list (ts :: 'a monom list) = showsp_list shows_prec 0 ts"

instance by (standard, auto simp: show_law_simps shows_list_monom_def)
end

fun shows_poly :: "('v :: {show,linorder},'a :: {one,show})poly  string  string" where 
  "shows_poly [] = shows_string ''0''"
| "shows_poly ((m,c) # p) = ((if c = 1 then shows m else if m = 1 then shows c else shows c +@+ 
     shows_string ''*'' +@+ shows m) +@+ (if p = [] then shows_string [] else shows_string '' + '' +@+ shows_poly p))"
end

Theory NZM

(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 Rene Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and Rene Thiemann
    License:     LGPL
*)

(*
Copyright 2009 Christian Sternagel, René Thiemann, Sarah Winkler, Harald Zankl

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section ‹Monotonicity criteria of Neurauter, Zankl, and Middeldorp›

theory NZM
imports "Abstract-Rewriting.SN_Order_Carrier" Polynomials
begin

text ‹
We show that our check on monotonicity is strong enough to capture the 
exact criterion for polynomials of degree 2 that is presented in \cite{NZM10}:
\begin{itemize}
\item $ax^2 + bx + c$ is monotone if $b + a > 0$ and $a \geq 0$
\item $ax^2 + bx + c$ is weakly monotone if $b + a \geq 0$ and $a \geq 0$
\end{itemize}
›

lemma var_monom_x_x [simp]: "var_monom x * var_monom x  1" 
  by (unfold eq_monom_sum_var, auto simp: sum_var_monom_mult sum_var_monom_var)

lemma monom_list_x_x[simp]: "monom_list (var_monom x * var_monom x) = [(x,2)]"
  by (transfer, auto simp: monom_mult_list.simps)

lemma assumes b: "b + a > 0" and a: "(a :: int)  0"
  shows "check_poly_strict_mono_discrete (>) (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def 
    extract_def check_poly_strict_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "b > 0  b  0" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

lemma assumes b: "b + a  0" and a: "(a :: int)  0" 
  shows "check_poly_weak_mono_discrete (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def 
    extract_def check_poly_weak_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "0  b" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

end